! REFERENCE MODEL WITH BARGAINING: verson with tau=a'/delta (25 May 2021)

! ifort -o  all  interp.f90 tauchen_mod.f90 golden.f90 Percentile_mod.f90 rtbis.f90 bobyqa.f90 calfun.f90 refmodelbargEV_v1.f90


! Log:
!23dec20 - no def when a=0
!13apr21 - option to repay always available
!14apr21 - temporarlity control duration of default, and also TT and AA
!23apr21 - option to walk away for lender; easy version: assuming never happens in equilibrium
!           so simply set H=max{H,0}
!03may21 - constraint tau>=0  when nu=1

!05may21 - consider model where tau=a'/delta
!02jun21 -  modified routines for EV shocks in bargaining

!11jun21 - temp changes to test discont at (prob nu=2)= 0
!12jun21 - temp changes to test discont at (prob nu=2)= 0 (II)
!15jun21 - second modification for EV shocks in bargaining
!16jun21 - amend value under EV shocks in good standing
!21jun21 - adapt [haircuts_extensions] and others to bargaining model
!28jun21 - option to inerpolate when theta=1

!03jul21 - limit recovery in negotiations nAtop
!04jul21 - limit spreads spr_array
!06jul21 - option to interpolate lender's proposal in [barg_nu2_ND]
!07jul21 - smooth price function
!15jul21 - automatic calibration options

!12aug21 - some changes in simul, investigating spreads
!13aug21 - changes in barg off the grid, to accomodate continuous restriction Atop
!14aug21 - further fix to barg off the grid
!15aug21 - manual option to set def under bargaining
!16aug21 - even further fix to barg off the grid, to make max of PC off the grid
!17aug21 - bracketing case nu=1 to smaller roor for recov net value for case where more than one root may exist
!12oct21 - case6 calibration
!13oct21 - speedh adjusted
!15oct21 - avoid NaN in statistics when def=0
!26oct21 - change error detection from rtbis
!27oct21 - fix error in barg under nu=1 by using <negat_wB_ND_c>, not <negat_valND_funf>

!02dec21 - make length_aver_stat global
!29dec21 - count artifical outcomes driven by EV shocks
!02jan22 - case9 calibration with output process and no haircut
MODULE mainmodule
    implicit none

  !******* file related: input/outputb *******
  integer, parameter:: defout=6

  integer::             nlines, ilines
  character (len=70)::  charline
  integer, parameter::  infile=20
  character (len=25)::  infname='input_refbarg.dat'
  character (len=25)::  outfname

  integer, parameter::  outfile1=21
  character (len=25)::  outfname1
  integer, parameter::  outfile2=22
  character (len=25)::  outfname2
  integer, parameter::  outfile4=24
  character (len=25)::  outfname4
  integer, parameter::  outfile7=27
  character (len=25)::  outfname7

  !******* controls of in/ouput *******
  integer :: readv, writev, readq, writeq
  integer :: readh, writeh

  integer :: finiteec
  integer :: niter
  integer :: offgridND

  !******* gral parameters *******
  integer, parameter:: prec= kind(1.d0) !prec=selected_real_kind(15, 307)
  real(prec), parameter:: one=1.0_prec, zero=0.0_prec
  real(prec), parameter:: two=2.0_prec, three=3.0_prec

  !******* Grids *******
  real(prec), parameter:: hhuge=10000000._prec
  real(prec), parameter:: closetozero=1.0E-06_prec, small=1.0E-06_prec
  real(prec) :: epshalf
  integer :: nz, nnu, ntheta
  integer :: nA, nAzero, nAneg, nB, nBneg, nBzero
  real(prec) :: gridA_dist, Amin, gridB_dist, Bmin
  real(prec), allocatable :: Aj(:)
  real(prec), allocatable :: Bj(:)
  real(prec), allocatable :: zj(:)

  !*******   Economic parameters *******
  real(prec) :: modelfreq
  real(prec) :: scaleuEV, sigEV
  real(prec) :: q0
  real(prec) :: delta, beta, sigma
  integer :: jzstar
  real(prec) :: Psimin, phi1, kappa, lambda

  integer :: useEV_in_barg  !15jun21
  real(prec) :: sigEV_B_nu1, sigEV_B_nu2   !15jun21

  real(prec), allocatable :: piz(:,:)
  real(prec), allocatable :: pinu(:,:)
  real(prec) :: rhoz, sdeta

  real(prec) :: zaver_glob

  !*******    Auxiliary variables: *******
  real(prec), dimension(:), allocatable :: zeros

  !******* Decision rules and value functions  *******
  real(prec),  allocatable ::  HH(:,:,:,:)
  real(prec),  allocatable ::  qq(:,:,:,:,:), qqtil(:,:,:,:)

  real(prec),  allocatable ::  vv(:,:,:,:), vv_temp(:,:,:,:)
  real(prec),  allocatable ::  vD(:,:,:) !, BD_c(:,:,:)
  real(prec),  allocatable ::  vND(:,:,:), BND_c(:,:,:)
  integer   ,  allocatable ::  locBND(:,:,:)
  integer   ,  allocatable ::  D01(:,:,:,:)

  real(prec),  allocatable ::  vB_O_nu1(:,:), vB_O_nu2(:,:)
  real(prec),  allocatable ::  vB_ND(:,:)
  real(prec),  allocatable ::  tauB_ND(:,:,:)
  real(prec),  allocatable ::  aprB_ND(:,:,:)
  real(prec),  allocatable ::  vB_D(:,:)
  real(prec),  allocatable ::  wB_ND(:,:)
  real(prec),  allocatable ::  wB_D(:,:)
  real(prec),  allocatable ::  vB_ND_nu2(:,:), vB_D_nu2(:,:)

  real(prec),  allocatable ::  DEF(:,:,:,:)
  real(prec),  allocatable ::  TT(:,:,:,:,:)
  real(prec),  allocatable ::  AA(:,:,:,:,:)

  !*******   summary statistics *******
  real(prec) :: a_aver2, freqdef, arrears, AtoY, Spr, sdC
  real(prec) :: corrSpr, sdSpr, corr_sprtb, smalldef
  real(prec) :: d_stdv_noncond



 !*******     Accuracies: *******
 integer :: iter_option, barg_option
 real(prec):: speed_adjq, qtol, speed_adjh, speed_adjdef, speed_adjb, speed_adjv
 real(prec) :: speed_adjh1, speed_adjh2      !13oct21
 integer :: iter_switch_speedh  !13oct21
 real(prec) :: bacc
 real(prec):: errmaxq, errmaxH, errmaxH0, errmaxH1, errmaxBND, errmaxV
 real(prec) :: errmaxDEF
 real(prec) :: tolall, tol_defb
 real(prec) :: tol0_offgridND
 integer :: interp_NDq, interp_NDv, interp_theta1v, interp_qtil, interp_H, interp_Hexp0
 integer :: interp_vBO
 integer :: barg_offgrid

 integer :: simulsize
 integer :: doIRF, doEVENT, dropjz_IRF
 integer :: ntimeIRF, npathsIRF
 integer :: lengthevent, maxlengthevent

 integer :: ifsmalldef

  !******* calibration ***********
  integer :: calibrcase
  real(prec) :: pinu1
  real(prec) ::  phi1_l, phi1_h, Psimin_l, Psimin_h, &
        &   beta_l, beta_h, &
        &  pinu1_l, pinu1_h
  real(prec) ::  sdeta_l, sdeta_h, rhoz_l, rhoz_h !02jan22

  real(prec) :: limit_spr, limit_Atop

  real(prec) :: spr_aver !15jul21
  real(prec) :: d_stdv, spr_stdv
  real(prec) :: debt_stdv
  real(prec) :: qqaver
  real(prec) :: logy_corr, logy_var
  real(prec) :: hhaircut
  real(prec) :: debtserv, debtserv_sd !12oct21

  integer :: step_calib
  real(prec) ::    AtoY_dat    , &
                  &  sprstdv_dat  , &
                  &  debtstdv_dat, freqdef_dat, arrears_dat, dstdv_dat, &
                  &  hhaircut_dat, &
                  & debtserv_dat, debtserv_sd_dat, & !12oct21
                  & logy_corr_dat, logy_sd_dat !02jan22
  real(prec) :: calibw_AtoY, calibw_sprsd, calibw_hairc, calibw_freq, calibw_def, calibw_dsd
  integer :: mv

 real(prec) ::  length_aver_stat   !02dec21

contains

!to allocate Aj Bj zj piz pinu HH qq qqtil qqtil_temp


  !********************************************************************
  ! [1.] READ INFO AND GRIDS
  !********************************************************************
  subroutine readinfo
  implicit none
    open (infile, file=infname, status='old')
    read (infile, *) outfname

    outfname1= 'f1_'//trim(outfname)//'.out'
    outfname2= 'f2_q_'//trim(outfname)//'.out'
    outfname4= 'f4_h_'//trim(outfname)//'.out'
    outfname7= 'f7_v_'//trim(outfname)//'.out'

    open (outfile1, file=outfname1)

    write(outfile1,*) '------------------------------------'
    write(outfile1,*) 'BARG ', 'experiment ', outfname
    write(outfile1,*) '------------------------------------'

    read (infile, *) nlines
    rewind(infile)
    do ilines =1,nlines
       read (infile, '(1a70)')  charline
       write(outfile1,*) charline
    end do
    rewind(infile)
    read (infile, *)
    read (infile, *)

    !Read info for grids and creates vectors
    call read_grids

    !Read info for economic parameters
    call read_ecpars

    !Input/output controls
    read (infile, *)
    read (infile, *) finiteec
    read (infile, *) niter
    read (infile, *) offgridND
    read (infile, *) tol0_offgridND
    read (infile, *) interp_NDq
    read (infile, *) interp_NDv
    read (infile, *) interp_vBO
    read (infile, *) interp_qtil
    read (infile, *) interp_theta1v
    read (infile, *) interp_H
    read (infile, *) interp_Hexp0
    read (infile, *) barg_offgrid
    read (infile, *) readq, writeq
    read (infile, *) readv, writev
    read (infile, *) readh, writeh

    ! calibration
    read (infile, *)
    read (infile, *) calibrcase

    !Accuracies
    read (infile, *)
    read (infile, *) iter_option
    read (infile, *) speed_adjq
    read (infile, *) speed_adjh1 !13oct21
    read (infile, *) speed_adjh2 !13oct21
    read (infile, *) iter_switch_speedh !13oct21
    read (infile, *) speed_adjdef
    read (infile, *) speed_adjb
    read (infile, *) speed_adjv
    read (infile, *) bacc
    read (infile, *) tolall
    read (infile, *) tol_defb
    read (infile, *)
    read (infile, *) simulsize
    read (infile, *) doEVENT
    read (infile, *) lengthevent
    read (infile, *) maxlengthevent
    read (infile, *) doIRF
    read (infile, *) dropjz_IRF
    read (infile, *) ntimeIRF, npathsIRF

    close (infile)

  end subroutine readinfo
  !********************************************************************
  subroutine read_grids
    implicit none
    integer :: ja, jb
    integer, dimension(1)::ishit

    read (infile, *)

    ! .. state position A ..
    read (infile, *) nA
    read (infile, *) gridA_dist
    read (infile, *) Amin
    allocate (Aj(nA))
    Aj(1)=zero
    Aj(2)= Amin
    do ja=2,nA-1
        Aj(ja+1)=Aj(ja) + gridA_dist
    end do
    do ja=1,nA
    write(outfile1,'(a5,i4,f9.6)') 'A', ja, Aj(ja)
    end do

    ! .. bonds B ..
    read (infile, *) nB
    read (infile, *) gridB_dist
    read (infile, *) Bmin
    !gridB_dist=(Bmax-Bmin)/(nB-1)
    epshalf=gridB_dist/two
    allocate (Bj(nB))
    Bj(1)= Bmin
    do jb=1,nB-1
        Bj(jb+1)=Bj(jb) + gridB_dist
    end do
    do jb=1,nB
    write(outfile1,'(a5,i4,f9.6)') 'B', jb, Bj(jb)
    end do




    allocate (zeros(nB))
    zeros=zero
   if(Bj(1).ge.zero-epshalf) then
    nBzero=1
   else
    ishit=maxloc(Bj(:), (Bj(:) .lt. zeros(:)-epshalf))
    nBneg=ishit(1)  ! the highest integer where Bi is < 0
    nBzero=nBneg+1  ! the integer where Bi is zero
    if(abs(Bj(nBzero)).gt.closetozero)then
       write(defout,*) 'B(nBzero) is too diff from zero', Bj(nBzero)
       write(outfile1,*) 'Bi(nBzero) is too diff from zero', abs(Bj(nBzero)),closetozero
       stop
    end if
   end if
    deallocate(zeros)


    nAzero=1
!    allocate (zeros(nA))
!    zeros=zero
!    ishit=maxloc(Aj(:), (Aj(:) .lt. zeros(:)-epshalf))
!    nAneg=ishit(1)  ! the highest integer where Bi is < 0
!    nAzero=nAneg+1  ! the integer where Bi is zero
!    if(abs(Aj(1)).lt.closetozero) nAzero=1
!    if(abs(Aj(nAzero)).gt.closetozero)then
!       write(defout,*) 'A(nAzero) is too diff from zero', Aj(nAzero)
!       write(outfile1,*) 'Ai(nAzero) is too diff from zero', abs(Aj(nAzero)),closetozero
!       stop
!    end if
!    if(nAzero.gt.1)then
!       write(defout,*) 'A(1) is negative! Sorry it only works for A(1)=0'
!       write(outfile1,*) 'A(1) is negative! Sorry it only works for A(1)=0'
!       stop
!    end if
!    deallocate(zeros)

    ! .. proposer nu (1 lender, 2 sovereign) ..
    read (infile, *) nnu
    allocate (pinu(nnu,nnu))

    ! .. standing ntheta (0 good ,1 bad) ..
    read (infile, *) ntheta

    ! .. productivity z ..
    read (infile, *) nz
    allocate (zj(nz))
    allocate (piz(nz,nz))
    read (infile, *) zj(1:10)

  end subroutine read_grids
  !********************************************************************
    subroutine read_ecpars
    use tauchen_mod
    implicit none
    integer :: jz, jzpr, jnu, jnupr
    read (infile, *)
    read (infile, *) modelfreq
    read (infile, *) scaleuEV
    read (infile, *) sigEV
    read (infile, *) useEV_in_barg  !15jun21
    read (infile, *) sigEV_B_nu1        !15jun21
    read (infile, *) sigEV_B_nu2        !15jun21
    read (infile, *) delta
    read (infile, *) sigma
    read (infile, *) beta
    read (infile, *) q0 ! Interest rate
    q0=one/(q0+one)     ! disocunt price
    read (infile, *) Psimin
    read (infile, *) jzstar
    read (infile, *) phi1
    read (infile, *) limit_spr
    read (infile, *) limit_Atop

    read (infile, *) lambda
    read (infile, *) kappa

    do jz=1,10
       read (infile, *) (piz(jz,jzpr), jzpr=1,10)  !transition
    end do
    read (infile, *) rhoz
    read (infile, *) sdeta
    call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    zj(1:nz)=exp(zj(1:nz))/two

    ! Identity of proposer transition
    do jnu=1,nnu
       read (infile, *) (pinu(jnu,jnupr), jnupr=1,nnu)
    end do
    read (infile, *) barg_option

    end subroutine read_ecpars

  !********************************************************************
   subroutine allocstuff
   implicit none

   allocate ( qqtil(nAzero:nA,0:ntheta,1:nz,1:nnu) )
   allocate ( HH(1:nA,0:ntheta,1:nz,1:nnu))
   allocate ( qq(1:nB,1:nA,0:ntheta,1:nz,1:nnu) )

!   allocate ( BD_c(1:nA,1:nz,1:nnu) )
   allocate ( vD(1:nA,1:nz,1:nnu) )
   allocate ( BND_c(1:nA,1:nz,1:nnu),locBND(1:nA,1:nz,1:nnu) )
   allocate ( vND(1:nA,1:nz,1:nnu) )
   allocate ( vv(1:nA,0:ntheta,1:nz,1:nnu), vv_temp(1:nA,0:ntheta,1:nz,1:nnu) )

   allocate(vB_O_nu1(1:nA,1:nz),vB_O_nu2(1:nA,1:nz))
   allocate(vB_ND_nu2(1:nA,1:nz), vB_D_nu2(1:nA,1:nz))
   allocate(vB_ND(1:nA,1:nz),vB_D(1:nA,1:nz))
   allocate(wB_ND(1:nA,1:nz),wB_D(1:nA,1:nz))
   allocate(aprB_ND(1:nA,1:nz,1:nnu),tauB_ND(1:nA,1:nz,1:nnu))

   allocate ( DEF(1:nA,0:ntheta,1:nz,1:nnu))

   allocate ( TT(1:nA,0:ntheta,1:nz,1:nnu,0:1))
   allocate ( AA(1:nA,0:ntheta,1:nz,1:nnu,0:1))

   end subroutine allocstuff

  !********************************************************************
  !initstuff
  !********************************************************************
  subroutine  initstuff
  implicit none
! Globals: finiteec
! Dependencies: call init_finiteec5
!

    qq=q0/(one-q0*delta)
    if(readq .eq. 1)then
       call read_q
    else
       qqtil=q0/(one-q0*delta)
    endif

    if(readh .eq. 1)then
       call read_h
    else
       HH=one
    endif

    if(readv .eq. 1)then
       call read_v
    else
       vv=-100.00_prec
    endif

!    if(readq .eq. 1)then
!       call read_q
!    else
!       qqtil=q0/(one-q0*delta)
!    endif
!
!    if(readv .eq. 1)then
!       call read_vD
!    else
!       vD=-100.00_prec
!    endif
!
!     if(readBandD .eq. 1)then !13apr13
!       call read_BD
!       call read_DD
!    else
!        locBD=1
!        locDD=1
!    endif
!
!
!    if(readh .eq. 1)then !16sep12
!       call read_h !05sep15
!       call read_hD !05sep15
!       call read_hND !05sep15
!    else
!       H=one
!    endif
!
!    if(readvND .eq. 1)then
!       call read_vND
!    else
!       vND=-100.00_prec
!    endif
!     if(readBND .eq. 1)then !13apr13
!       call read_BND
!    else
!        locBND=1
!    endif
!
!    if(readD01 .eq. 1)then
!       call read_D01
!    else
!       D01=1
!       D01(:,nAzero,:)=0
!    endif

    aprB_ND=zero

    if(finiteec .eq. 5) call init_finiteec5
    if(finiteec .eq. 6) call init_finiteec6

  end subroutine initstuff
! ************************************************
 subroutine init_finiteec5
! Globals: HH vD vv vND DEF BND_c (OUT)
!          nz zj
! Locals: jz yy ddd
! Dependencies: function utt psi
!
 implicit none
 integer :: jz, ddd
 real(prec) :: yy

!   qq=zero
!   qqtil=zero
    HH(:,1,:,:)=zero
    HH(:,0,:,:)=zero !one
    do jz=1, nz
     ddd=1
     yy=zj(jz)*psi(ddd,jz)
     vD(:,jz,:)=utt(yy)
     vv(:,1,jz,:)=utt(yy)
    end do
     vND(:,:,:)=vD(:,:,:)-.001_prec
     vv(:,0,:,:)=vND(:,:,:)

     DEF(:,:,:,:)=1

! .. These are just ..
    BND_c=zero

 end subroutine init_finiteec5

! ************************************************
 subroutine init_finiteec6
! Globals: HH vD vv vND DEF BND_c (OUT)
!          nz zj
! Locals: jz yy ddd
! Dependencies: function utt psi
!
 implicit none
 integer :: jz, ddd
 real(prec) :: yy

!   qq=zero
!   qqtil=zero
    HH(:,1,:,:)=zero
    HH(:,0,:,:)=zero !one
    vv(:,:,:,:)=zero
!    do jz=1, nz
!     ddd=1
!     yy=zj(jz)*psi(ddd,jz)
!     vv(:,1,jz,:)=utt(yy)
!     ddd=0
!     yy=zj(jz)*psi(ddd,jz)
!     vv(:,0,jz,:)=utt(yy)
!    end do

!     DEF(:,:,:,:)=1

! .. These are just ..
    BND_c=zero

 end subroutine init_finiteec6

  !********************************************************************
  ! [2.] READ/WRITE INITIAL CONDITIONS
  !********************************************************************

  subroutine read_q
  implicit none
  integer :: japr, jthetapr, jz, jnu
  open (outfile2, file=outfname2)
    do japr=nAzero,nA
     do jthetapr=0, ntheta
      do jz=1, nz
       do jnu=1, nnu
        read(outfile2,*) qqtil(japr,jthetapr,jz,jnu)
       end do
      end do
     end do
    end do
  close(outfile2)
  end subroutine read_q

  subroutine write_q
  implicit none
  integer :: japr, jthetapr, jz, jnu
  open (outfile2, file=outfname2)
    do japr=nAzero,nA
     do jthetapr=0, ntheta
      do jz=1, nz
       do jnu=1, nnu
        write(outfile2,*) qqtil(japr,jthetapr,jz,jnu)
       end do
      end do
     end do
    end do
  close(outfile2)
  end subroutine write_q

  subroutine read_h
  implicit none
  integer :: ja, jtheta, jz, jnu
  open (outfile4, file=outfname4)
    do ja=1,nA
     do jtheta = 0, ntheta
      do jz=1, nz
       do jnu=1, nnu
        read(outfile4,*) HH(ja,jtheta,jz,jnu)
       end do
      end do
     end do
    end do
  close(outfile4)
  end subroutine read_h

  subroutine write_h
  implicit none
  integer :: ja, jtheta, jz, jnu
  open (outfile4, file=outfname4)
    do ja=1,nA
     do jtheta = 0, ntheta
      do jz=1, nz
       do jnu=1, nnu
        write(outfile4,*) HH(ja,jtheta,jz,jnu)
       end do
      end do
     end do
    end do
  close(outfile4)
  end subroutine write_h

  subroutine read_v
  implicit none
  integer :: ja, jtheta, jz, jnu
  open (outfile7, file=outfname7)
    do ja=1,nA
     do jtheta = 0, ntheta
      do jz=1, nz
       do jnu=1, nnu
        read(outfile7,*) vv(ja,jtheta,jz,jnu)
       end do
      end do
     end do
    end do
  close(outfile7)
  end subroutine read_v

  subroutine write_v
  implicit none
  integer :: ja, jtheta, jz, jnu
  open (outfile7, file=outfname7)
    do ja=1,nA
     do jtheta = 0, ntheta
      do jz=1, nz
       do jnu=1, nnu
        write(outfile7,*) vv(ja,jtheta,jz,jnu)
       end do
      end do
     end do
    end do
  close(outfile7)
  end subroutine write_v


! *********************************************************
 subroutine stat_distr
! Globals:   zaver_glob (OUT)
!            piz, nz
!            pinu nnu, outfile1

    implicit none
    integer :: time, j
    real(prec), dimension(:), allocatable:: distr(:)
    allocate(distr(nz))

    open(297, file='stat_distr.dat')

     distr=one/real(nz)
     do time=1, 2000
      distr=matmul(transpose(piz),distr)
     end do
     write(outfile1,*)
     write(outfile1,'(a30)') 'Stationary distribution z'
     write(outfile1,'(a5,15f9.6)') 'z', (zj(j), j=1, nz)
     write(outfile1,'(a5,15f9.6)') 'prob', (distr(j), j=1, nz)
     write(297,'(a30)') 'Stationary distribution z'
     write(297,'(a5,15f9.6)') 'z', (zj(j), j=1, nz)
     write(297,'(a5,15f9.6)') 'prob', (distr(j), j=1, nz)
     !write(297,'(15f9.6)') (distr(j), j=1, nz)
   close(297)

    zaver_glob=sum(zj(:)*distr(:))
    deallocate(distr)
    write(outfile1,*)
    write(outfile1,'(a10,f7.4)') 'Mean z ', zaver_glob

    open(297, file='transprob_nu.dat')
    write(297,'(a30)') 'Prob distrib nu'
     write(297,'(15f9.6)') (pinu(1,j), j=1, nnu)
     write(297,'(15f9.6)') (pinu(2,j), j=1, nnu)
   close(297)
     write(outfile1,'(a30)') 'Prob distrib nu'
     write(outfile1,'(15f9.6)') (pinu(1,j), j=1, nnu)
     write(outfile1,'(15f9.6)') (pinu(2,j), j=1, nnu)

 end subroutine stat_distr




!*************************************************************
! [3.] SOVEREIGN
!*************************************************************
 subroutine agentD_opt
! Globals:
!           nnu nz nA zj piz pinu
!           beta vv
!           vD      (OUT)
! Locals:
!           jtheta jnu jz ja jthetapr japr jnupr
!           cons yy vexpD
! Dependencies: utt

  implicit none
  integer :: jnu, jz, ja, jthetapr, japr, jnupr, jtheta
  real(prec) :: cons, yy, vexpD

  jtheta=0
  do jnu= 1, nnu
   do jz=  1, nz
    do ja= 1, nA
     jthetapr=1
     japr=ja
     yy=zj(jz)
     cons=yy
     vexpD=zero
     do jnupr=1,nnu
      vexpD=vexpD+pinu(jnu,jnupr)*sum(piz(jz,:)*vv(japr,jthetapr,:,jnupr))
     end do
      vD(ja,jz,jnu)=utt(cons)+beta*vexpD
    end do
   end do
  end do

 end subroutine agentD_opt

!*************************************************************
  subroutine agentND_opt
! Globals: nnu nz nA nB
!          vND locBND BND_c errmaxBND(OUT)
!
! Locals: jnu ja jz jthetapr jtheta
!         uttND_array vexpND_array, vND_temp BNDold
!         ishit1 bb
!         natspli
!
! Dependencies:
!    call uttND_array_defi (contained)
!    call vexpND_array_defi (contained)
!    use interp
!    golden
!    call spline

  use interp
  implicit none
  integer :: jnu, ja, jz, jthetapr, jtheta
  integer :: jjb, jjapr
  integer, dimension(1)::ishit1
  real(prec), allocatable :: uttND_array(:),vexpND_array(:)
  real(prec), allocatable :: spr_array(:) !04jul21
  real(prec), allocatable :: vND_temp(:,:,:)
  real(prec),  allocatable :: BNDold(:,:,:)
  real(prec) :: golden, bb

  real(prec), allocatable :: qq2d(:)
  real(prec), allocatable :: vv2d(:,:,:)
  real(prec) :: natspli


  allocate (uttND_array(nB),vexpND_array(nB))
  allocate (spr_array(nB))                   !04jul21
  allocate ( vND_temp(1:nA,1:nz,1:nnu) )
  allocate ( BNDold(1:nA,1:nz,1:nnu))
  allocate ( qq2d(1:nB))
  allocate ( vv2d(1:nA,1:nz,1:nnu))


  BNDold=BND_c

    if(interp_NDv.eq.2) then
    ! .. build spline for vv ..
    natspli=1.0E30_prec+small
    jtheta=0
    do jnu= 1, nnu
     do jz=  1, nz
      call spline(Aj(1:nA),vv(1:nA,jtheta,jz,jnu),natspli,natspli,vv2d(1:nA,jz,jnu))
     end do
    end do
    end if

  jtheta=0
  jthetapr=0
  do jnu= 1, nnu
   do jz=  1, nz
    do ja= 1, nA

  ! Grid optimisation
     call uttND_array_defi
     call vexpND_array_defi
!     ishit1=maxloc(&
!         &  uttND_array(1:nB)+beta*vexpND_array(1:nB)  )
     ishit1=maxloc(&
         &  uttND_array(1:nB)+beta*vexpND_array(1:nB),spr_array(1:nB).lt.limit_spr) !04jul21
     locBND(ja,jz,jnu) =ishit1(1)+1-1
     BND_c(ja,jz,jnu)=Bj(locBND(ja,jz,jnu))
     vND_temp(ja,jz,jnu)=uttND_array(locBND(ja,jz,jnu))+beta*vexpND_array(locBND(ja,jz,jnu))


!++++++
!++ if((jz.eq.5).and.(ja.eq.22)) then
!++  open(297, file='bND_temp.dat')
!++   write(297,'(4a4,a14,2a24)') 'jnu', 'jz', 'ja', 'jjb', 'Bj', 'u+beta*vexp', 'spr_array'
!++  do jjb=1, nB
!++   write(297,'(4i4,f14.7,2f24.17)') jnu, jz, ja, jjb, Bj(jjb), &
!++    &   uttND_array(jjb)+beta*vexpND_array(jjb), spr_array(jjb)
!++  end do
!++  close(297)
!++ end if
!++++++

  ! Add off-grid optimisation
  if(offgridND.eq.1) then

    if(interp_NDq.eq.2) then
    ! .. build spline for q ..
    natspli=1.0E30_prec+small
    call spline(Bj(1:nB),qq(1:nB,ja,jthetapr,jz,jnu),natspli,natspli,qq2d)
    end if

     if( (locBND(ja,jz,jnu).gt.1).and.(locBND(ja,jz,jnu).lt.nB).and. &
        & (vvND_c(Bj(locBND(ja,jz,jnu))).gt.vvND_c(Bj(max(1,locBND(ja,jz,jnu)-1)))) &
        &   .and. &
        & (vvND_c(Bj(locBND(ja,jz,jnu))).gt.vvND_c(Bj(min(nB,locBND(ja,jz,jnu)+1))))  ) then
       vND_temp(ja,jz,jnu)=-golden( &
        & Bj(locBND(ja,jz,jnu)-1), &
        & Bj(locBND(ja,jz,jnu)), Bj(locBND(ja,jz,jnu)+1), &
        &   negat_vvND_c, tol0_offgridND,  bb)
!       vND_temp(ja,jz,jnu)=-golden( &
!        & Bj(max(locBND(ja,jz,jnu)-4,1)), &
!        & Bj(locBND(ja,jz,jnu)), Bj(min(locBND(ja,jz,jnu)+4,nB)), &
!        &   negat_vvND_c, tol0_offgridND,  bb)
     else
        vND_temp(ja,jz,jnu)=-negat_vvND_c(Bj(locBND(ja,jz,jnu)))
        bb=Bj(locBND(ja,jz,jnu))
     end if
    BND_c(ja,jz,jnu)=bb
    !vND_temp(ja,jz,jnu)= vvND_c(BND_c(ja,jz,jnu))
  end if
  ! end off-grid optim

    end do
   end do
  end do

  vND=vND_temp


  errmaxBND=maxval(abs(BND_c-BNDold))



    open(297, file='agentND_fig.dat')
    write(297,'(2a3,a5,x,7a14)') 'jnu','jz','ja', 'a', 'Bj', 'BND ', 'BNDold', 'err', 'q', 'qb'
  do jnu= 1, nnu
   do jz=  1, nz
    do ja= 1, nA
    write(297,'(2i3,i5,x,7f14.4)') jnu,jz,ja, Aj(ja), Bj(locBND(ja,jz,jnu)), BND_c(ja,jz,jnu), BNDold(ja,jz,jnu), abs(BND_c(ja,jz,jnu)-BNDold(ja,jz,jnu)), &
        & qq(locBND(ja,jz,jnu),ja,jthetapr,jz,jnu), Bj(locBND(ja,jz,jnu))*qq(locBND(ja,jz,jnu),ja,jthetapr,jz,jnu)
    end do
   end do
  end do
    close(297)

 BND_c(:,:,:)=speed_adjb*BND_c(:,:,:)+(one-speed_adjb)*BNDold(:,:,:)

  deallocate(uttND_array,vexpND_array,vND_temp,BNDold)
  deallocate(spr_array)
  deallocate (qq2d, vv2d)


!-----------------------------------------------------------------------
  contains
!-----------------------------------------------------------------------
  subroutine uttND_array_defi
! Globals: nB delta Bj Aj small hhuge qq
!
! Globals (host agentND_opt):  ja jthetapr jz jnu
!                              uttND_array (OUT)
!
! Locals: jb bsmall blarge cons
!
!
! Dependencies: function utt

   implicit none
   integer :: jb
   logical :: bsmall, blarge
   real(prec) :: cons
   real(prec), parameter:: small=0.0_prec


   do jb=1, nB
     bsmall=.false.
     blarge=.false.
     if((Bj(jb)+delta*Aj(ja)).lt.Aj(1)-small) bsmall=.true.
     if((Bj(jb)+delta*Aj(ja)).gt.Aj(nA)) blarge=.true.
     if(blarge.or.bsmall) then
      uttND_array(jb)=-hhuge
     else
      cons=zj(jz)+ Bj(jb)*qq(jb,ja,jthetapr,jz,jnu)-Aj(ja)
      uttND_array(jb)=utt(cons)
      spr_array(jb)= (((one/qq(jb,ja,jthetapr,jz,jnu))+delta)**modelfreq)  &
            &       -((one/q0)**modelfreq)  !04jul21
     end if
   end do
  end subroutine uttND_array_defi
!-----------------------------------------------------------------------
  subroutine vexpND_array_defi
! Globals: nB nnu nz delta Bj Aj small hhuge qq
!          vv
!
! Globals (host agentND_opt): vexpND_array (OUT)
!                             jthetapr jz jnu, ja
!
! Locals: jb jnupr jzpr bsmall blarge
!         vinterp aapr
!
! Dependencies: function vvinterp
!               function lip
   implicit none
   integer :: jb, jnupr, jzpr
   real(prec) :: aapr, vinterp
   logical :: bsmall, blarge
   real(prec), parameter:: small=0.0_prec

   do jb=1, nB
     bsmall=.false.
     blarge=.false.
     if((Bj(jb)+delta*Aj(ja)).lt.Aj(1)-small) bsmall=.true.
     if((Bj(jb)+delta*Aj(ja)).gt.Aj(nA)) blarge=.true.
     if(blarge.or.bsmall) then
      vexpND_array(jb)=-hhuge
     else
      aapr=delta*Aj(ja)+Bj(jb)
      vexpND_array(jb)=zero
      do jnupr=1,nnu
       do jzpr=1, nz
       !vinterp=lip(Aj(:),vv(:,jthetapr,jzpr,jnupr),aapr) !naive
       vinterp=vvinterp(aapr,jthetapr,jzpr,jnupr)         !controls kinks
       vexpND_array(jb)=vexpND_array(jb)+pinu(jnu,jnupr)*piz(jz,jzpr)*vinterp
       end do
      end do
     end if
   end do
  end subroutine vexpND_array_defi
!-----------------------------------------------------------------------
  function vvinterp(aapr,jthetapr,jzpr,jnupr)
  implicit none
! Globals: Aj
!          vv
!
! Globals (host agentND_opt): vvinterp (OUT)
!                             vv2d (IN)
!
! Local: aapr jthetapr jzpr jnupr
!        apr
!        japrlow, japrup
!        vtemp_ND vtemp_D
!
! Dependencies: lip, splint
!
  real(prec), intent(in) :: aapr
  integer, intent(in)    :: jthetapr, jzpr, jnupr
  real(prec) :: apr
  integer    :: japrlow, japrup
  real(prec) :: vtemp_ND, vtemp_D
  real(prec) :: vvinterp

  apr=aapr
!!  apr=max(Aj(1), aapr)
!!  apr=min(Aj(na), apr)
!!  japrlow=count(Aj.le.apr)
!!  japrup=min(japrlow+1,nA)

!if(ifEVoption.eq.0) then
!  if(D01(japrlow,jthetapr,jzpr,jnupr).eq.1) then
!    vvinterp=lip(Aj(:),vD(:,jzpr,jnupr),apr)
!  else if(D01(japrlow,jthetapr,jzpr,jnupr).eq.0) then
!    vvinterp=lip(Aj(:),vND(:,jzpr,jnupr),apr)
! else
!    vtemp_ND=lip(Aj(:),vND(:,jzpr,jnupr),apr)
!    vtemp_D=lip(Aj(:),vD(:,jzpr,jnupr),apr)
!    if ( vtemp_ND.ge.vtemp_D) then
!      vvinterp=vtemp_ND
!    else
!      vvinterp=vtemp_D
!    end if
! end if
!else if(ifEVoption.eq.1) then
    !vtemp_ND=lip(Aj(:),vND(:,jzpr,jnupr),apr)
    !vtemp_D=lip(Aj(:),vD(:,jzpr,jnupr),apr)
    !vvinterp=DEF(japrlow,jthetapr,jzpr,jnupr)*vtemp_D &
    !    & +(one-DEF(japrlow,jthetapr,jzpr,jnupr))*vtemp_ND

    if(interp_NDv.eq.1) &
     & vvinterp=lip(Aj(:),vv(:,jthetapr,jzpr,jnupr),apr)
    if(interp_NDv.eq.2) &
     & vvinterp=splint(Aj(1:nA),vv(1:nA,jthetapr,jzpr,jnupr),vv2d(1:nA,jzpr,jnupr),apr)

  end function vvinterp
!-----------------------------------------------------------------------
  function uttND_c(bb)

! Globals: nB delta Bj Aj small hhuge qq
!
! Globals (host agentND_opt): ja jthetapr jz jnu
!
! Locals: jb bsmall blarge cons qa bb
!          uttND_c (OUT)
!
! Dependencies: function utt lip splint

   implicit none
   logical :: bsmall, blarge
   real(prec) :: cons, qa
   real(prec) uttND_c, bb
   !real(prec), parameter:: small=0.0_prec

     bsmall=.false.
     blarge=.false.
     !!!**** if(bb.lt.Bj(1)) bsmall=.true.
     if(bb.gt.Bj(nB)) blarge=.true.
     !!!**** if((bb+delta*Aj(ja)).lt.Aj(1)-small) bsmall=.true.
     if((bb+delta*Aj(ja)).gt.Aj(nA)) blarge=.true.
     if(blarge.or.bsmall) then
      uttND_c=-hhuge
     else
      if(interp_NDq.eq.1) &
       & qa= lip(Bj(1:nB),qq(1:nB,ja,jthetapr,jz,jnu),bb)
      if(interp_NDq.eq.2) &
       & qa=splint(Bj(1:nB),qq(1:nB,ja,jthetapr,jz,jnu),qq2d(1:nB),bb)
      cons=zj(jz)+ bb*qa-Aj(ja)
      uttND_c=utt(cons)
     end if

  end function uttND_c
!-----------------------------------------------------------------------
  function vexpND_c(bb)
! Globals: nB nnu nz delta Bj Aj small hhuge qq
!          vv
!
! Globals (host agentND_opt): jthetapr jz jnu, ja
!
! Locals: jnupr jzpr bsmall blarge
!         vinterp aapr bb
!          vexpND_c (OUT)
!
! Dependencies: function vvinterp
!               function lip
   implicit none
   integer :: jnupr, jzpr
   real(prec) :: aapr, vinterp
   logical :: bsmall, blarge
   real(prec) vexpND_c, bb
   real(prec), parameter:: small=0.0_prec

     bsmall=.false.
     blarge=.false.
     !!!**** if(bb.lt.Bj(1)) bsmall=.true.
     if(bb.gt.Bj(nB)) blarge=.true.
     !!!****if((bb+delta*Aj(ja)).lt.Aj(1)-small) bsmall=.true.
     if((bb+delta*Aj(ja)).gt.Aj(nA)) blarge=.true. !+small
     if(blarge.or.bsmall) then
      vexpND_c=-hhuge
     else
      aapr=delta*Aj(ja)+bb
      aapr=min(aapr,Aj(nA))
      aapr=max(aapr,Aj(1))
      vexpND_c=zero
      do jnupr=1,nnu
       do jzpr=1, nz
       !vinterp=lip(Aj(:),vv(:,jthetapr,jzpr,jnupr),aapr) !naive
       vinterp=vvinterp(aapr,jthetapr,jzpr,jnupr)         !controls kinks
       vexpND_c=vexpND_c+pinu(jnu,jnupr)*piz(jz,jzpr)*vinterp
       end do
      end do
     end if

  end function vexpND_c

!-----------------------------------------------------------------------
  function vvND_c(bbb)
   implicit none
   real(prec) :: bbb, vvND_c
   vvND_c=uttND_c(bbb)+beta*vexpND_c(bbb)
  end function vvND_c

  function negat_vvND_c(bb)
   implicit none
    real(prec) :: bb
   real(prec) :: negat_vvND_c
   negat_vvND_c=-vvND_c(bb)
  end function negat_vvND_c
!-----------------------------------------------------------------------

  end subroutine agentND_opt

!*************************************************************
 subroutine  nobarg_iter
! Locals:  jnu jz jtheta ja
!          DEFold u_aux termND termD
!
! Globals:  nnu nz  nA Aj delta
!           vD vND
!           vv errmaxDEF DEF TT AA (OUT)
 implicit none
 integer :: jnu,jz,jtheta,ja
 real(prec) :: u_aux, termD, termND
 real(prec),  allocatable ::  DEFold(:,:,:,:)

 allocate ( DEFold(1:nA,0:ntheta,1:nz,1:nnu))

!if(ifEVoption.eq.0) then
! DEFold=DEF
! D01old=D01
! jtheta=0
! do jnu=1, nnu
!  do jz = 1, nz
!   do ja=1,nA
!    if(vD(ja,jz,jnu).gt.vND(ja,jz,jnu)) then
!      vv(ja,jtheta,jz,jnu)=vD(ja,jz,jnu)
!      D01(ja,jtheta,jz,jnu)=1
!      DEF(ja,jtheta,jz,jnu)=one
!      TT(ja,jtheta,jz,jnu)=zero
!      AA(ja,jtheta,jz,jnu)=Aj(ja)
!    else
!      vv(ja,jtheta,jz,jnu)=vND(ja,jz,jnu)
!      D01(ja,jtheta,jz,jnu)=0
!      DEF(ja,jtheta,jz,jnu)=zero
!      TT(ja,jtheta,jz,jnu)=Aj(ja) !!BND_c(ja,jz,jnu)
!      AA(ja,jtheta,jz,jnu)=delta*Aj(ja)+BND_c(ja,jz,jnu)
!    end if
!   end do
!  end do
! end do
!else if(ifEVoption.eq.0) then
 DEFold=DEF
 jtheta=0
 do jnu=1, nnu
  do jz = 1, nz
   do ja=nAzero,nA
    !if(ja.gt.nAzero) then
     u_aux=sigEV*log(scaleuEV)-max(vD(ja,jz,jnu),vND(ja,jz,jnu))
     termD=exp((vD(ja,jz,jnu)+u_aux)/sigEV)
     termND=exp((vND(ja,jz,jnu)+u_aux)/sigEV)
     vv_temp(ja,jtheta,jz,jnu)=-sigEV*log(two)+sigEV*log(termND+termD)-u_aux !16jun21
     DEF(ja,jtheta,jz,jnu)=termD/(termD+termND)
    !else
    ! DEF(ja,jtheta,jz,jnu)=zero
    ! vv_temp(ja,jtheta,jz,jnu)=vND(ja,jz,jnu)
    !end if

!!*    ! .. Case no EV shocks ..
!!*    if(vD(ja,jz,jnu).gt.vND(ja,jz,jnu)) then
!!*      vv_temp(ja,jtheta,jz,jnu)=vD(ja,jz,jnu)
!!*      DEF(ja,jtheta,jz,jnu)=one
!!*    else
!!*      vv_temp(ja,jtheta,jz,jnu)=vND(ja,jz,jnu)
!!*      DEF(ja,jtheta,jz,jnu)=zero
!!*    end if

    TT(ja,jtheta,jz,jnu,0)=Aj(ja)
    AA(ja,jtheta,jz,jnu,0)=min(Aj(nA),max(Aj(1),delta*Aj(ja)+BND_c(ja,jz,jnu)))
    TT(ja,jtheta,jz,jnu,1)=zero
    AA(ja,jtheta,jz,jnu,1)=Aj(ja)   !21jun21: need adapt to episodes' accounting?

   end do
  end do
 end do

 errmaxDEF=maxval(DEFold(nAzero+1:nA,0:ntheta,1:nz,1:nnu)-DEF(nAzero+1:nA,0:ntheta,1:nz,1:nnu))

open(297, file='DEF_fig.dat')
write(297,'(3a3,a5,x,4a8)') 'jnu', 'jth','jz','ja', 'a',   &
           &   'DEF ', 'DEFold ', 'diffD'
do jnu=1, nnu
 do jtheta=0, 0 !ntheta
  do jz = 1, nz
   do ja=1,nA
    write(297,'(3i3,i5,x,4f8.4)') jnu,jtheta,jz,ja,    &
           &   Aj(ja), &
           &   DEF(ja,jtheta,jz,jnu), DEFold(ja,jtheta,jz,jnu), &
           &   abs(DEF(ja,jtheta,jz,jnu)- DEFold(ja,jtheta,jz,jnu))
   end do
  end do
 end do
end do
close(297)

    DEF(:,:,:,:)=speed_adjdef*DEF(:,:,:,:)+(one-speed_adjdef)*DEFold(:,:,:,:)

 deallocate(DEFold)

 end subroutine  nobarg_iter



!*************************************************************
! [4.] FUNCTIONS FOR SOVEREIGN
!*************************************************************
 function utt(ctt)
    implicit none
    real(prec) :: utt, ctt
    if(ctt.gt.0.00001_prec) then
        utt=(((ctt)**(one-sigma))/(one-sigma))
    else
        utt=-hhuge
    end if
 end function utt

  function psi(def01,jz_psi)
! Globals: jzstar Psimin phi1
!           zj
! Local: zstar
!        def01 jz_psi
!        psi
!
    implicit none
    integer :: def01, jz_psi
    real(prec) :: psi
    real(prec) :: zstar

    if(jzstar.eq.0) then
     zstar=zero
    else
     zstar=zj(jzstar)
    end if

    if(def01.eq.1) then
     if(jz_psi.le.jzstar) then
        psi=one-(one-Psimin)
     else
        psi=(one-phi1*(zj(jz_psi)-zstar)) * &
         &  (one-(one-Psimin))
     end if
    else
        psi=one
    end if

  end function psi


!*************************************************************
! [5.] BARGAINING - i.e. BAD STANDING
!*************************************************************
 subroutine barg_iter
! Globals: nz nA nnu Aj
!          DEF TT AA (OUT)
!
! Local: jtheta jnu jz ja
!
 implicit none
 integer :: jtheta, jnu, jz, ja

 ! --------------------------------------------------------
 ! Exogenous case: no recovery
!!* jtheta=1
!!* do jnu=1, nnu
!!*  do jz = 1, nz
!!*   do ja=1,nA
!!*    !case: no recovery; reentry prob lambda
!!*    DEF(ja,jtheta,jz,jnu)=one-lambda !.20_prec !1-lambda
!!*    TT(ja,jtheta,jz,jnu,0)=zero                 !Aj(ja)*.25_prec
!!*    AA(ja,jtheta,jz,jnu,0)=Aj(nAzero)           !Aj(ja)
!!*    TT(ja,jtheta,jz,jnu,1)=zero
!!*    AA(ja,jtheta,jz,jnu,1)=Aj(ja)
!!*   end do
!!*  end do
!!* end do

 ! --------------------------------------------------------
 ! Exogenous case: recovery; immediate settlement


 ! --------------------------------------------------------
 ! Endogenous: alternating offers

 ! Components when no agreement d01=1
 jtheta=1
 do jnu=1, nnu
  do jz = 1, nz
   do ja=1,nA
    TT(ja,jtheta,jz,jnu,1)=zero
    AA(ja,jtheta,jz,jnu,1)=Aj(ja)  !21jun21: need adapt to episodes' accounting?
   end do
  end do
 end do


  if(useEV_in_barg.eq.0) then
    if(barg_option.eq.1) call barg_outopt !13apr21
    call barg_nu1_ND
    call barg_nu1_D
    !call barg_nu1_D     !12jun21
    !call barg_nu1_ND    !12jun21
    call barg_nu1
    call barg_nu2_ND
    call barg_nu2_D
    !call barg_nu2_D     !12jun21
    !call barg_nu2_ND    !12jun21
    call barg_nu2
  end if

if(useEV_in_barg.eq.1) then
    call barg_nu1_ND
    call barg_nu1_D
    call barg_nu1_EVshocks
    call barg_nu2_ND
    call barg_nu2_D
    call barg_nu2_EVshocks
end if

 end subroutine barg_iter

! ******************************************************************
 subroutine barg_outopt
 ! Outside option to payback
 ! Global: vB_O_u1 vB_O_u2 interp_vBO,
 ! Local: vexp1 vexp2 vv2d natspli jthera jthetaps jnu jz aapr cons
  use interp
  implicit none

  real(prec), allocatable :: vv2d(:,:,:)
  real(prec) :: natspli
  real(prec) :: vexp1, vexp2, aapr, cons
  integer :: jtheta, jthetapr, jnu, jnupr, jz, ja, jzpr

  allocate ( vv2d(1:nA,1:nz,1:nnu))

    if(interp_vBO.eq.2) then
    ! .. build spline for vv ..
    natspli=1.0E30_prec+small
    jtheta=0
    do jnu= 1, nnu
     do jz=  1, nz
      call spline(Aj(1:nA),vv(1:nA,jtheta,jz,jnu),natspli,natspli,vv2d(1:nA,jz,jnu))
     end do
    end do
    end if

   jtheta=1
   jthetapr=0
   do jz=  1, nz
    do ja= 1, nA
     aapr=delta*Aj(ja)
     cons=zj(jz)*psi(jtheta,jz)
     vexp1=zero
     vexp2=zero
     do jnupr=1,nnu
      do jzpr=1, nz
      jnu=1
      vexp1=vexp1+pinu(jnu,jnupr)*piz(jz,jzpr)*vvinterp_outopt(aapr,jthetapr,jzpr,jnupr)
      jnu=2
      vexp2=vexp2+pinu(jnu,jnupr)*piz(jz,jzpr)*vvinterp_outopt(aapr,jthetapr,jzpr,jnupr)
      end do
     end do
      vB_O_nu1(ja,jz)=utt(cons)+beta*vexp1
      vB_O_nu2(ja,jz)=utt(cons)+beta*vexp2
    end do
   end do


    open(297, file='v_outopt.dat')
    write(297,'(3a3,a5,x,5a10)') 'jnu', 'jth','jz','ja', 'a',   &
               &   'vB_O_nu1 ', 'vB_O_nu2 ', 'vB_ND_nu2', 'vB_D_nu2'
      do jz = 1, nz
       do ja=1,nA
        write(297,'(3i3,i5,x,5f10.4)') jnu,jtheta,jz,ja,    &
               &   Aj(ja), &
               &   vB_O_nu1(ja,jz), vB_O_nu2(ja,jz), &
               &   vB_ND_nu2(ja,jz), vB_D_nu2(ja,jz)
       end do
      end do
    close(297)

  deallocate (vv2d)


!-----------------------------------------------------------------------
 contains
!-----------------------------------------------------------------------
  function vvinterp_outopt(aapr,jthetapr,jzpr,jnupr)
  implicit none
! Globals: Aj
!          vv
!
! Globals (host barg_nu1_outopt): vvinterp (OUT)
!
! Local: aapr jthetapr jzpr jnupr
!        apr
!        japrlow, japrup
!        vtemp_ND vtemp_D
!
! Dependencies: lip, splint
!
  real(prec), intent(in) :: aapr
  integer, intent(in)    :: jthetapr, jzpr, jnupr
  real(prec) :: apr
  integer    :: japrlow, japrup
  real(prec) :: vtemp_ND, vtemp_D
  real(prec) :: vvinterp_outopt

  apr=aapr

    if(interp_vBO.eq.1) &
     & vvinterp_outopt=lip(Aj(:),vv(:,jthetapr,jzpr,jnupr),apr)
    if(interp_vBO.eq.2) &
     & vvinterp_outopt=splint(Aj(1:nA),vv(1:nA,jthetapr,jzpr,jnupr),vv2d(1:nA,jzpr,jnupr),apr)

  end function vvinterp_outopt

 end subroutine barg_outopt
! ******************************************************************

!*************************************************************
 subroutine barg_nu1
!
! Local: jtheta jnu ja jz
!        DEFold
!
! Globals:  Aj
!           vB_ND vB_D aprB_ND tauB_ND
!           DEF TT AA
!
    implicit none
    integer :: jtheta, jnu, ja, jz
    real(prec),  allocatable ::  DEFold(:,:)
    allocate(DEFold(1:nA,1:nz))

    jtheta=1
    jnu=1
    DEFold(1:nA,1:nz)=DEF(1:nA,jtheta,1:nz,jnu)

if((barg_option.eq.0).or.(barg_option.eq.2)) then
!13apr21: coment in if flag does not apply
 do ja=1, nA
  do jz=1, nz
    if(vB_ND(ja,jz).ge.vB_D(ja,jz)) then
     DEF(ja,jtheta,jz,jnu)=zero
    else
     DEF(ja,jtheta,jz,jnu)=one
    end if
    AA(ja,jtheta,jz,jnu,0)=aprB_ND(ja,jz,jnu)
    !!DEF(ja,jtheta,jz,jnu)=zero !one-lambda    !14apr21  TEMP arrang
    !!AA(ja,jtheta,jz,jnu,0)=zero !14apr21  TEMP arrang
  end do
 end do
 TT(:,jtheta,:,jnu,0)=tauB_ND(:,:,jnu)
 !!TT(:,jtheta,:,jnu,0)=zero !14apr21  TEMP arrang
end if

!13apr21
if(barg_option.eq.1) then
 do ja=1, nA
  do jz=1, nz
   if(max(vB_ND(ja,jz),vB_D(ja,jz)).le.vB_O_nu1(ja,jz)) then !13apr21
        DEF(ja,jtheta,jz,jnu)=zero
        AA(ja,jtheta,jz,jnu,0)=delta*Aj(ja)
        TT(ja,jtheta,jz,jnu,0)=Aj(ja)
   else
        if(vB_ND(ja,jz).ge.vB_D(ja,jz)) then
            DEF(ja,jtheta,jz,jnu)=zero
        else
            DEF(ja,jtheta,jz,jnu)=one
        end if
        AA(ja,jtheta,jz,jnu,0)=aprB_ND(ja,jz,jnu)
        TT(ja,jtheta,jz,jnu,0)=tauB_ND(ja,jz,jnu)
   end if
  end do
 end do
end if

    open(297, file='DEF_barg_nu1_fig.dat')
    write(297,'(3a3,a5,x,4a8,2a12)') 'jnu', 'jth','jz','ja', 'a',   &
               &   'DEF ', 'DEFold ', 'diffD', 'vB_ND', 'vB_D'
      do jz = 1, nz
       do ja=1,nA
        write(297,'(3i3,i5,x,4f8.4,2f12.8)') jnu,jtheta,jz,ja,    &
               &   Aj(ja), &
               &   DEF(ja,jtheta,jz,jnu), DEFold(ja,jz), &
               &   abs(DEF(ja,jtheta,jz,jnu)- DEFold(ja,jz)), &
               &   vB_ND(ja,jz), vB_D(ja,jz)
       end do
      end do
    close(297)

    deallocate(DEFold)

 end subroutine barg_nu1


!*************************************************************
 subroutine barg_nu1_ND
 !
 ! Globals: beta nA nz
 !          aprB_ND tauB_ND vB_ND
 !
 ! Local: jz ja jtheta jthetapr jnu
 !        uttB_ND_array vexpB_ND_array
 !        aprB_NDold locaprB_ND
 !
 ! Dependencies: call uttB_ND_array_defi vexpB_ND_array_defi
 !               func tauB_ND_func
 !
 use interp
 implicit none
 integer :: jz, ja, jtheta, jthetapr, jnu
 integer, dimension(1)::ishit1
 real(prec),  allocatable ::  uttB_ND_array(:), vexpB_ND_array(:)
 real(prec),  allocatable :: aprB_NDold(:,:)
 real(prec),  allocatable :: recov_ND_array(:)
 real(prec) ::  qqq
 integer :: locaprB_ND
 integer :: jjapr
 integer :: nAbott
 integer :: japrlower, japrupper
 !real(prec) pacc
 integer :: errmess !26oct21
 real(prec) rtbis
 external rtbis

 allocate(uttB_ND_array(1:nA), vexpB_ND_array(1:nA))
 allocate(aprB_NDold(1:nA,1:nz))
! allocate(tauB_ND_func_to_arr(1:nA))  !23apr21
 allocate(recov_ND_array(1:nA)) !05may21

  jtheta=1
  jnu=1
  jthetapr=0

  aprB_NDold(1:nA,1:nz)=aprB_ND(1:nA,1:nz,jnu)

!!*  jnu=2
!!*  open(297, file='HH1_temp.dat')
!!*  write(297,'(2a3,a21)') 'jz', 'ja',  'HH'
!!*  do jz=1, nz
!!*   do ja=1, nA
!!*   write(297,'(2i3,2f21.7)') jz, ja, Aj(ja), HH(ja,1,jz,jnu)
!!*   end do
!!*  end do
!!*  close(297)

! --------------------
! On the grid
! --------------------

if(barg_offgrid.eq.0) then

  do jz=  1, nz
   do ja= 1, nA

     call uttB_ND_array_defi
     call vexpB_ND_array_defi
     call recov_ND_array_defi   !05may21
     !call tauB_ND_func_to_arr_defi !23apr21

 if((jz.eq.1).and.(ja.eq.2)) then
  open(297, file='nu1_ND_temp.dat')
  do jjapr=1, nA
   write(297,'(3i,f14.7,f30.7,f24.17)') jz, ja, jjapr, Aj(jjapr), uttB_ND_array(jjapr)+beta*vexpB_ND_array(jjapr), recov_ND_array(jjapr)
  end do
  close(297)
 end if

!   nAbott=count(Aj(1:nA).le.0.15_prec*delta*Aj(ja))

!11jun21
   if(maxval(recov_ND_array).ge.zero) then !05may21
     ishit1=maxloc(&
         &  uttB_ND_array(1:nA)+beta*vexpB_ND_array(1:nA), recov_ND_array(1:nA).ge.zero) !05may21
!!     ishit1=maxloc(&
!!         &  uttB_ND_array(1:nA)+beta*vexpB_ND_array(1:nA),  &
!!         &  tauB_ND_func_to_arr(1:nA)+Aj(1:nA)*qqtil(1:nA,jthetapr,jz,jnu).ge.zero ) !23apr21
     locaprB_ND =ishit1(1)+1-1

!    !nAbott
!     ishit1=maxloc(&
!         &  uttB_ND_array(nAbott:nA)+beta*vexpB_ND_array(nAbott:nA), recov_ND_array(nAbott:nA).ge.zero) !05may21
!     locaprB_ND =ishit1(1)+nAbott-1


     aprB_ND(ja,jz,jnu)=Aj(locaprB_ND)
     tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
     vB_ND(ja,jz)=uttB_ND_array(locaprB_ND) &
            &       +beta*vexpB_ND_array(locaprB_ND)

!    !nAbott
!     aprB_ND(ja,jz,jnu)=.70_prec*Aj(ja)
!     tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!     vB_ND(ja,jz)=lip(Aj(:),uttB_ND_array(:) &
!            &       +beta*vexpB_ND_array(:),aprB_ND(ja,jz,jnu))


   else
     aprB_ND(ja,jz,jnu) =zero
     tauB_ND(ja,jz,jnu)=zero
     vB_ND(ja,jz)=-hhuge
     !vB_ND(ja,jz)=vB_D(ja,jz)-small !12jun21
   end if

   end do
  end do

end if


! --------------------
! Off the grid
! --------------------

if(barg_offgrid.eq.1) then

!write(outfile1,*) 'rtbis nu1 '

  do jz=  1, nz
   do ja= 1, nA

     call uttB_ND_array_defi
     call vexpB_ND_array_defi
     call recov_ND_array_defi   !05may21

   if(maxval(recov_ND_array).gt.zero) then

     if(recov_ND_array(1).ge.zero) then
        aprB_ND(ja,jz,jnu)=zero
        tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
        locaprB_ND=1
        vB_ND(ja,jz)=uttB_ND_array(locaprB_ND) &
            &       +beta*vexpB_ND_array(locaprB_ND)
     else
        ishit1=maxloc(recov_ND_array(1:nA))
        !japrupper=ishit1(1)+1-1
        !17aug21
        japrupper=1
        do japrupper=1, nA
            if (recov_ND_array(japrupper).gt.zero) exit
        end do
        japrlower=1
        !pacc=0.00001_prec
        !pacc=0.0000001_prec
        aprB_ND(ja,jz,jnu)=rtbis(recov_ND_func,Aj(japrlower),Aj(japrupper),bacc,errmess) !26oct21
        if(errmess.eq.1) then !26oct21
            write(*,*) 'rtbis bracketing err in [barg_nu1_ND] '
            stop
        end if
        tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
        vB_ND(ja,jz)=lip(Aj(:),uttB_ND_array(:)+beta*vexpB_ND_array(:),aprB_ND(ja,jz,jnu))
     end if

   else
     aprB_ND(ja,jz,jnu) =zero
     tauB_ND(ja,jz,jnu)=zero
     vB_ND(ja,jz)=-hhuge
   end if

   end do
  end do

end if



    open(297, file='barg_nu1_ND_fig.dat')
    write(297,'(2a3,a5,x,7a14)') 'jnu','jz','ja', 'a', 'tau','apr',  'aprold', 'erra','q', 'qb'
  do jnu= 1, 1
   do jz=  1, nz
    do ja= 1, nA
    qqq=lip(Aj(:),qqtil(:,jthetapr,jz,jnu),aprB_ND(ja,jz,jnu))
    write(297,'(2i3,i5,x,7f14.4)') jnu,jz,ja, Aj(ja), tauB_ND(ja,jz,jnu), &
        & aprB_ND(ja,jz,jnu), &
        & aprB_NDold(ja,jz), abs(aprB_ND(ja,jz,jnu)-aprB_NDold(ja,jz)), &
        & qqq, &
        & aprB_ND(ja,jz,jnu)*qqq
    end do
   end do
  end do
    close(297)


 deallocate(uttB_ND_array,vexpB_ND_array)
 deallocate(aprB_NDold)
 deallocate(recov_ND_array)
 !deallocate(tauB_ND_func_to_arr)
  contains
 !------------------------------------------------------------------
 function recov_ND_func(aprdum)
 implicit none
 real(prec) :: aprdum
 real(prec) :: recov_ND_func
    recov_ND_func=lip(Aj(:),recov_ND_array(:),aprdum)
 end function recov_ND_func
 !------------------------------------------------------------------
!05may21
 subroutine recov_ND_array_defi
  implicit none
  integer :: japr_dum, jnupr
  real(prec) :: sum_aux

integer ::  jzpr
!!*jnupr=2
!!*  open(297, file='HH1_temp.dat')
!!*  write(297,'(2a3,a21)') 'jz', 'ja',  'HH'
!!*  do japr_dum=1, nA
!!*   do jzpr=1, nz
!!*   write(297,'(2i3,f21.7)') jzpr, japr_dum,  HH(japr_dum,1,jzpr,jnupr)
!!*   end do
!!*  end do
!!*  close(297)


   do japr_dum= 1, nA
     sum_aux=zero
     do jnupr=1,nnu
        sum_aux=sum_aux &
            &  + pinu(jnu,jnupr) &
            &  * sum(piz(jz,:)* &
            &   (   &
            &    Aj(japr_dum)*HH(japr_dum,0,:,jnupr) &
            &   -Aj(ja)*HH(ja,1,:,jnupr) &
            &   ) &
            &   )

!11jun21
! if((jnupr.eq.1).and.(jnu.eq.1))         sum_aux=sum_aux &
!             &   +pinu(jnu,jnupr)*sum(piz(jz,:)* &
!             &   (   &
!             &     Aj(japr_dum)*HH(japr_dum,0,:,jnupr) &
!             &   -Aj(ja)*HH(ja,1,:,jnupr) &
!             &   ) &
!             &   )
! if((jnupr.eq.1).and.(jnu.eq.2))         sum_aux=sum_aux &
!             &   +pinu(jnu,jnupr)*sum(piz(jz,:)* &
!             &   (   &
!             &     Aj(japr_dum)*HH(japr_dum,0,:,jnupr) &
!             &   -Aj(ja)*HH(ja,1,:,jnupr) &
!             &   ) &
!             &   )
! if((jnupr.eq.2).and.(jnu.eq.1))         sum_aux=sum_aux &
!             &   +pinu(jnu,jnupr)*sum(piz(jz,:)* &
!!             &   +0.0000000000000000000000001_prec*sum(piz(jz,:)* &
!             &   (   &
!             &     Aj(japr_dum)*HH(japr_dum,0,:,jnupr) &
!             &   -Aj(ja)*HH(ja,1,:,jnupr) &
!             &   ) &
!             &   )
! if((jnupr.eq.2).and.(jnu.eq.2))         sum_aux=sum_aux &
!             &   +pinu(jnu,jnupr)*sum(piz(jz,:)* &
!             &   (   &
!             &     Aj(japr_dum)*HH(japr_dum,0,:,jnupr) &
!             &   -Aj(ja)*HH(ja,1,:,jnupr) &
!             &   ) &
!             &   )
!11jun21
! if((jnupr.eq.2).and.(jnu.eq.1).and.(ja.eq.2))  &
!    & write(*,'(2i5,3f35.30)') jnu, jnupr, pinu(jnu,jnupr), pinu(jnu,jnupr)*sum(piz(jz,:)),            &
!             &     sum(piz(jz,:)*Aj(japr_dum)*HH(japr_dum,0,:,jnupr) &
!             &   -Aj(ja)*HH(ja,1,:,jnupr) )
!!!    & write(*,'(2i5,3f35.30)') jnu, jnupr, pinu(jnu,jnupr),             &

 !if(jnupr.eq.1) wexpBD=wexpBD+sum(piz(jz,:)*HH(japr,jthetapr,:,jnupr))
 !if(jnupr.eq.2) wexpBD=wexpBD

     end do
         recov_ND_array(japr_dum)=Aj(japr_dum)/delta+ q0*sum_aux
   end do

!if((jz.eq.1).and.(ja.eq.2)) then
!  open(299, file='recov_ND.dat')
!  write(299,'(5a6,3a30)') 'jz', 'ja', 'japr', 'nupr', 'jzpr', 'Aj*HH(.,1,.,.)', 'temp','temp2'
!end if
!
!  do japr_dum= 1, nA
!    sum_aux=zero
!    do jnupr=1,nnu
!     do jzpr=1,nz
!        sum_aux=sum_aux &
!            &  + pinu(jnu,jnupr) &
!            &  * (piz(jz,jzpr)* &
!            &   (   &
!            &    Aj(japr_dum)*HH(japr_dum,0,jzpr,jnupr) &
!            &   -Aj(ja)*HH(ja,1,jzpr,jnupr) &
!            &   ) &
!            &   )
!if((jz.eq.1).and.(ja.eq.2)) then
!write(299,'(5i6,3f30.7)') jz, ja, japr_dum, jnupr, jzpr, Aj(ja)*HH(ja,1,jzpr,jnupr), &
!            &  piz(jz,jzpr)* &
!            &   (   &
!            &    Aj(japr_dum)*HH(japr_dum,0,jzpr,jnupr) &
!            &   -Aj(ja)*HH(ja,1,jzpr,jnupr)  ), &
!            &  pinu(jnu,jnupr)*piz(jz,jzpr)* &
!            &   (   &
!            &    Aj(japr_dum)*HH(japr_dum,0,jzpr,jnupr) &
!            &   -Aj(ja)*HH(ja,1,jzpr,jnupr)  )
!
!end if
!     end do
!    end do
!        recov_ND_array(japr_dum)=Aj(japr_dum)/delta+ q0*sum_aux
!  end do
!
!if((jz.eq.1).and.(ja.eq.2)) then
!  close(299)
!end if

 end subroutine recov_ND_array_defi
 !------------------------------------------------------------------
!!!23apr21
!! subroutine tauB_ND_func_to_arr_defi
!!  integer :: ja_dum
!!  do ja_dum= 1, nA
!!   tauB_ND_func_to_arr(ja_dum)=tauB_ND_func(ja_dum)
!!  end do
!! end subroutine tauB_ND_func_to_arr_defi
!!
!! !------------------------------------------------------------------
!! function tauB_ND_func(japr_dum)
!! !
!! ! Global: pinu piz HH Aj nnu q0
!! !
!! ! Global (host): jz jnu ja
!! !
!! ! Local: japr_dum jnupr
!! !        sum_aux
!! !        tauB_ND_func
!! !
!! implicit none
!! integer :: japr_dum, jnupr
!! real(prec) sum_aux, tauB_ND_func
!!
!! sum_aux=zero
!! do jnupr=1,nnu
!!  sum_aux=sum_aux+pinu(jnu,jnupr) &
!!    & *sum(piz(jz,:)*(Aj(ja)*HH(ja,1,:,jnupr) &
!!    &       -Aj(japr_dum)*HH(japr_dum,0,:,jnupr)) )
!! end do
!! tauB_ND_func=q0*sum_aux
!!
!! if(tauB_ND_func.lt.zero) tauB_ND_func=zero !03may21
!!
!!
!! end function tauB_ND_func

 !------------------------------------------------------------------
 subroutine uttB_ND_array_defi
 !
 ! Global: nA
 !
 ! Global (host): jtheta jz
 !                uttB_ND_array (OUT)
 !
 ! Local: yy tau cons
 !        japr
 !
 ! Dependencies: func tauB_ND_func psi utt
 !
 implicit none
 integer :: japr
 real(prec) :: yy, tau, cons

 do japr=1, nA
    tau=Aj(japr)/delta
    yy=zj(jz)*psi(jtheta,jz)
    cons=yy-tau
    uttB_ND_array(japr)=utt(cons)
 end do

 end subroutine uttB_ND_array_defi

 !------------------------------------------------------------------
 subroutine vexpB_ND_array_defi
!
! Global: nA nnu pinu piz
!         vv
!
! Global (host): jtheta jnu jz
!                vexpB_ND_array
!
! Local: japr sum_aux jnupr
!
 implicit none
 integer :: japr, jnupr
 real(prec) :: sum_aux

 do japr=1, nA
   sum_aux=zero
   do jnupr=1,nnu
    sum_aux=sum_aux+pinu(jnu,jnupr) &
      & *sum(piz(jz,:)*vv(japr,jthetapr,:,jnupr))
   end do
   vexpB_ND_array(japr)=sum_aux
 end do

 end subroutine vexpB_ND_array_defi


 !------------------------------------------------------------------
 end subroutine barg_nu1_ND


!*************************************************************
 subroutine barg_nu1_D
!
! Global: nz nA nnu pinu piz vv
!         vB_D
!
! Local: jnu jtheta jthetapr jz ja japr jnupr
!        yy cons vexpBD

 implicit none
 integer :: jnu, jtheta, jthetapr, jz, ja, japr, jnupr
 real(prec) :: yy, cons, vexpBD

   jnu=1
   jtheta=1
   jthetapr=1
   do jz=  1, nz
    do ja= 1, nA
     japr=ja
     yy=zj(jz)*psi(jtheta,jz)
     cons=yy
     vexpBD=zero
     do jnupr=1,nnu
      vexpBD=vexpBD+pinu(jnu,jnupr)*sum(piz(jz,:)*vv(japr,jthetapr,:,jnupr))
     end do
      vB_D(ja,jz)=utt(cons)+beta*vexpBD
    end do
   end do

 end subroutine barg_nu1_D

! ***********************************************************
 subroutine barg_nu2
!
! Local: jtheta jnu ja jz
!        DEFold
!
! Globals:  Aj
!           wB_ND wB_D aprB_ND tauB_ND
!           DEF TT AA
!
    implicit none
    integer :: jtheta, jnu, ja, jz
    real(prec),  allocatable ::  DEFold(:,:)
    real(prec) :: vaux
    allocate(DEFold(1:nA,1:nz))

    jtheta=1
    jnu=2
    DEFold(1:nA,1:nz)=DEF(1:nA,jtheta,1:nz,jnu)

!13apr21: comment in if flag does not apply
if((barg_option.eq.0).or.(barg_option.eq.2)) then
    do ja=1, nA
     do jz=1, nz
    if(wB_ND(ja,jz).ge.wB_D(ja,jz)) then
     DEF(ja,jtheta,jz,jnu)=zero
    else
     DEF(ja,jtheta,jz,jnu)=one
    end if
    AA(ja,jtheta,jz,jnu,0)=aprB_ND(ja,jz,jnu)
    !!AA(ja,jtheta,jz,jnu,0)=zero         !14apr21  TEMP arrang
    !!DEF(ja,jtheta,jz,jnu)=zero !one-lambda    !14apr21  TEMP arrang
     end do
    end do
    TT(:,jtheta,:,jnu,0)=tauB_ND(:,:,jnu)
    !!TT(:,jtheta,:,jnu,0)=zero           !14apr21  TEMP arrang
end if

!13apr21
if(barg_option.eq.1) then
 do ja=1, nA
  do jz=1, nz
    if(wB_ND(ja,jz).ge.wB_D(ja,jz)) then
     vaux=vB_ND_nu2(ja,jz)
    else
     vaux=vB_D_nu2(ja,jz)
    end if
   if(vaux.le.vB_O_nu2(ja,jz)) then
        DEF(ja,jtheta,jz,jnu)=zero
        AA(ja,jtheta,jz,jnu,0)=delta*Aj(ja)
        TT(ja,jtheta,jz,jnu,0)=Aj(ja)
   else
        if(wB_ND(ja,jz).ge.wB_D(ja,jz)) then
         DEF(ja,jtheta,jz,jnu)=zero
        else
         DEF(ja,jtheta,jz,jnu)=one
        end if
        AA(ja,jtheta,jz,jnu,0)=aprB_ND(ja,jz,jnu)
        TT(ja,jtheta,jz,jnu,0)=tauB_ND(ja,jz,jnu)
   end if
  end do
 end do
end if

    open(297, file='DEF_barg_nu2_fig.dat')
    write(297,'(3a3,a5,x,4a8,2a12)') 'jnu', 'jth','jz','ja', 'a',   &
               &   'DEF ', 'DEFold ', 'diffD', 'wB_ND', 'wB_D '
      do jz = 1, nz
       do ja=1,nA
        write(297,'(3i3,i5,x,4f8.4,2f12.8)') jnu,jtheta,jz,ja,    &
               &   Aj(ja), &
               &   DEF(ja,jtheta,jz,jnu), DEFold(ja,jz), &
               &   abs(DEF(ja,jtheta,jz,jnu)- DEFold(ja,jz)), &
               &    wB_ND(ja,jz), wB_D(ja,jz)
       end do
      end do
    close(297)

    deallocate(DEFold)

 end subroutine barg_nu2
! ***********************************************************
 subroutine barg_nu2_ND
 !
 ! Globals: q0 nA nz
 !          aprB_ND tauB_ND wB_ND
 !
 ! Local: jz ja jtheta jthetapr jnu
 !        tauB_ND_array aHexpB_ND_array
 !        aprB_NDold locaprB_ND
 !
 ! Dependencies: call tauB_ND_array_defi aHexpB_ND_array_defi
 !
!16aug21: comment out
!!!** use interp
!!!** implicit none
!!!** integer :: jz, ja, jtheta, jthetapr, jnu
!!!** integer, dimension(1)::ishit1
!!!** real(prec),  allocatable ::  tauB_ND_array(:), aHexpB_ND_array(:)
!!!** real(prec),  allocatable :: aprB_NDold(:,:)
!!!** real(prec),  allocatable :: val_ND_array(:) !05may21
!!!** integer :: jthetapr_aux, japr, jnupr
!!!** integer :: locaprB_ND
!!!** real(prec) :: ttau, yy, cons, vexp
!!!** real(prec) :: qqq
!!!** integer :: nAtop
!!!** real(prec) :: aapr, aupper, alower
!!!** real(prec) :: golden
!!!** integer :: japrlower, japrupper
!!!** !real(prec) pacc
!!!** real(prec) rtbis
!!!** real(prec) :: Atop, aprlower, aprupper
!!!** external rtbis
!!!**
!!!** allocate(tauB_ND_array(1:nA), aHexpB_ND_array(1:nA))
!!!** allocate(val_ND_array(1:nA)) !05may21
!!!** allocate(aprB_NDold(1:nA,1:nz))
!!!**
!!!**
!!!**  jtheta=1
!!!**  jnu=2
!!!**  jthetapr=0
!!!**
!!!**  aprB_NDold(1:nA,1:nz)=aprB_ND(1:nA,1:nz,jnu)
!!!**
!!!**! --------------------
!!!**! On the grid
!!!**! --------------------
!!!**if(barg_offgrid.eq.0) then
!!!**
!!!**  do jz=  1, nz
!!!**   do ja= 1, nA
!!!**     !call tauB_ND_array_defi
!!!**     call aHexpB_ND_array_defi
!!!**     call tauB_ND_array_defi !13apr21
!!!**     call val_ND_array_defi !05may21
!!!**
!!!**  ! .. write out ..
!!!**  if((jz.eq.4).and.(ja.eq.2)) then
!!!**  open(297, file='nu2_ND_temp.dat')
!!!**  write(297,'(3a3,a5,x,4a14)') 'jnu','jz','ja', 'japr','apr', 'tau+qEH','tau',  'qEH', 'netval'
!!!**    do japr= 1, nA
!!!**    write(297,'(3i3,i5,x,5f14.6)') jnu,jz,ja, japr, Aj(japr), &
!!!**        & tauB_ND_array(japr)+q0*aHexpB_ND_array(japr), &
!!!**        & tauB_ND_array(japr), q0*aHexpB_ND_array(japr), val_ND_array(japr)
!!!**    end do
!!!**  close(297)
!!!**  end if
!!!**
!!!**
!!!**
!!!**    ! .. Use restriction on lender's plans: can't get more that you are owed ..
!!!**!03jul21
!!!**   nAtop=count(Aj(1:nA).le.limit_Atop*delta*Aj(ja))
!!!**   !nAtop=nA !ja
!!!**   !nAtop=count(Aj(1:nA).le.2.5_prec*delta*Aj(ja))
!!!**   if(maxval(val_ND_array(1:nAtop)).ge.zero) then !05may21
!!!**     ishit1=maxloc(&
!!!**        &  tauB_ND_array(1:nAtop)+q0*aHexpB_ND_array(1:nAtop),val_ND_array(1:nAtop).ge.zero) !05may21
!!!**     locaprB_ND =ishit1(1)+1-1
!!!**     aprB_ND(ja,jz,jnu)=Aj(locaprB_ND)
!!!**     tauB_ND(ja,jz,jnu)=tauB_ND_array(locaprB_ND)
!!!**     wB_ND(ja,jz)=tauB_ND_array(locaprB_ND) &
!!!**            &       +q0*aHexpB_ND_array(locaprB_ND)
!!!**!06jul21
!!!**!    ! .. if off-grid maximisation ..
!!!**!      if((locaprB_ND.lt.nA).and.(locaprB_ND.gt.1)   &
!!!**!        &   .and.(val_ND_array(locaprB_ND+1).ge.zero)) then
!!!**!        ! Bracket interval:
!!!**!        alower=Aj(locaprB_ND-1)
!!!**!        if(val_ND_array(locaprB_ND+1).ge.zero) then
!!!**!          aupper=Aj(locaprB_ND+1)
!!!**!        else ! .. need to find bound via linear interpolation ..
!!!**!          aupper=Aj(locaprB_ND+1)    &
!!!**!            &   -(Aj(locaprB_ND+1)-Aj(locaprB_ND)) &
!!!**!            &   *val_ND_array(locaprB_ND)  &
!!!**!            &       /(val_ND_array(locaprB_ND)-val_ND_array(locaprB_ND+1))
!!!**!        end if
!!!**!        ! Optimise new function on continuum negat_wB_ND_c
!!!**!        wB_ND(ja,jz)=-golden( &
!!!**!         &   alower,Aj(locaprB_ND),aupper, &
!!!**!         &   negat_wB_ND_c, tol0_offgridND,  aapr)
!!!**!      end if
!!!**!        aprB_ND(ja,jz,jnu) = aapr
!!!**!        tauB_ND(ja,jz,jnu)=aapr/delta
!!!**   else
!!!**     aprB_ND(ja,jz,jnu) =zero
!!!**     tauB_ND(ja,jz,jnu)=zero
!!!**     wB_ND(ja,jz)=-hhuge
!!!**     !wB_ND(ja,jz)=wB_D(ja,jz)-small !12jun21
!!!**   end if
!!!**
!!!**!   if(maxval(val_ND_array).ge.zero) then !05may21
!!!**!     ishit1=maxloc(&
!!!**!        &  tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA),val_ND_array(1:nA).ge.zero) !05may21
!!!**!     locaprB_ND(ja,jz,jnu) =ishit1(1)+1-1
!!!**!     tauB_ND(ja,jz,jnu)=tauB_ND_array(locaprB_ND(ja,jz,jnu))
!!!**!     wB_ND(ja,jz)=tauB_ND_array(locaprB_ND(ja,jz,jnu)) &
!!!**!            &       +q0*aHexpB_ND_array(locaprB_ND(ja,jz,jnu))
!!!**!   else
!!!**!     locaprB_ND(ja,jz,jnu) =nAzero
!!!**!     tauB_ND(ja,jz,jnu)=zero
!!!**!     wB_ND(ja,jz)=-hhuge
!!!**!     !wB_ND(ja,jz)=wB_D(ja,jz)-small !12jun21
!!!**!   end if
!!!**
!!!**
!!!**     !13apr21
!!!**    if(barg_option.eq.1) then
!!!**     jthetapr_aux=0
!!!**     japr=locaprB_ND
!!!**     aprB_ND(ja,jz,jnu)=Aj(japr)
!!!**     ttau=tauB_ND(ja,jz,jnu)
!!!**     yy=zj(jz)*psi(jtheta,jz)
!!!**     cons=yy-ttau
!!!**     vexp=zero
!!!**     do jnupr=1,nnu
!!!**      vexp=vexp+pinu(jnu,jnupr)*sum(piz(jz,:)*vv(japr,jthetapr_aux,:,jnupr))
!!!**     end do
!!!**      vB_ND_nu2(ja,jz)=utt(cons)+beta*vexp
!!!**    end if
!!!**
!!!**   end do
!!!**  end do
!!!**
!!!**end if
!!!**
!!!**
!!!**! --------------------
!!!**! Off the grid
!!!**! --------------------
!!!**
!!!**!++if(barg_offgrid.eq.1) then
!!!**!++
!!!**!++!write(outfile1,*) 'rtbis nu2 '
!!!**!++
!!!**!++  do jz=  1, nz
!!!**!++   do ja= 1, nA
!!!**!++     call aHexpB_ND_array_defi
!!!**!++     call tauB_ND_array_defi !13apr21
!!!**!++     call val_ND_array_defi !05may21
!!!**!++
!!!**!++  ! .. write out ..
!!!**!++  if((jz.eq.2).and.(ja.eq.32)) then
!!!**!++  open(297, file='nu2_ND_temp.dat')
!!!**!++  write(297,'(3a3,a5,x,4a14)') 'jnu','jz','ja', 'japr','apr', 'tau+qEH','tau',  'qEH', 'netval'
!!!**!++    do japr= 1, nA
!!!**!++    write(297,'(3i3,i5,x,5f14.6)') jnu,jz,ja, japr, Aj(japr), &
!!!**!++        & tauB_ND_array(japr)+q0*aHexpB_ND_array(japr), &
!!!**!++        & tauB_ND_array(japr), q0*aHexpB_ND_array(japr), val_ND_array(japr)
!!!**!++    end do
!!!**!++  close(297)
!!!**!++  end if
!!!**!++  if((jz.eq.2).and.(ja.eq.23)) then
!!!**!++  open(297, file='nu2_ND_temp3.dat')
!!!**!++  write(297,'(3a3,a5,x,4a14)') 'jnu','jz','ja', 'japr','apr', 'tau+qEH','tau',  'qEH', 'netval'
!!!**!++    do japr= 1, nA
!!!**!++    write(297,'(3i3,i5,x,5f14.6)') jnu,jz,ja, japr, Aj(japr), &
!!!**!++        & tauB_ND_array(japr)+q0*aHexpB_ND_array(japr), &
!!!**!++        & tauB_ND_array(japr), q0*aHexpB_ND_array(japr), val_ND_array(japr)
!!!**!++    end do
!!!**!++  close(297)
!!!**!++  end if
!!!**!++
!!!**!++
!!!**!++   nAtop=nA !ja
!!!**!++   !nAtop=count(Aj(1:nA).le.Aj(ja))
!!!**!++
!!!**!++   if(maxval(val_ND_array(1:nAtop)).gt.zero) then
!!!**!++     ishit1=maxloc(&
!!!**!++        &  tauB_ND_array(1:nAtop)+q0*aHexpB_ND_array(1:nAtop))
!!!**!++     locaprB_ND =ishit1(1)+1-1
!!!**!++
!!!**!++
!!!**!++!!        if(locaprB_ND.lt.nAtop) then
!!!**!++         if(val_ND_array(locaprB_ND).ge.zero) then
!!!**!++            aprB_ND(ja,jz,jnu)=Aj(locaprB_ND)
!!!**!++            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!!!**!++            wB_ND(ja,jz)=tauB_ND_array(locaprB_ND) &
!!!**!++                &       +q0*aHexpB_ND_array(locaprB_ND)
!!!**!++
!!!**!++         else
!!!**!++            japrlower=1
!!!**!++            japrupper=locaprB_ND
!!!**!++!            japrlower=count(val_ND_array(1:nAtop).gt.zero)
!!!**!++!            japrupper=japrlower+1 !count(val_ND_array(1:nAtop).ge.zero)
!!!**!++!            japrupper=max(nAtop,japrupper+1)
!!!**!++            pacc=0.00001_prec
!!!**!++!            write(outfile1,*) 'rtbis nu2 locaprB_ND.lt.nAtop'
!!!**!++            aprB_ND(ja,jz,jnu)=rtbis(val_ND_func,Aj(japrlower),Aj(japrupper),pacc)
!!!**!++            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!!!**!++!            wB_ND(ja,jz)=tauB_ND_array(locaprB_ND) &
!!!**!++!                &       +q0*aHexpB_ND_array(locaprB_ND)
!!!**!++            wB_ND(ja,jz)=lip(Aj(1:nAtop),       &
!!!**!++             &   tauB_ND_array(1:nAtop)+q0*aHexpB_ND_array(1:nAtop), &
!!!**!++             &      aprB_ND(ja,jz,jnu))
!!!**!++
!!!**!++         end if
!!!**!++!!        end if
!!!**!++
!!!**!++!!        if(locaprB_ND.ge.nAtop) then
!!!**!++!!            japrlower=1 !count(val_ND_array(1:nAtop).gt.zero)
!!!**!++!!            japrupper=nAtop !japrlower+1 !count(val_ND_array(1:nAtop).ge.zero)
!!!**!++!!            !japrupper=max(nAtop,japrupper+1)
!!!**!++!!            pacc=0.00001_prec
!!!**!++!!            write(outfile1,*) 'rtbis nu2 locaprB_ND.ge.nAtop'
!!!**!++!!            aprB_ND(ja,jz,jnu)=rtbis(val_ND_func,Aj(japrlower),Aj(japrupper),pacc)
!!!**!++!!            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!!!**!++!!            wB_ND(ja,jz)=tauB_ND_array(locaprB_ND) &
!!!**!++!!                &       +q0*aHexpB_ND_array(locaprB_ND)
!!!**!++!!        end if
!!!**!++
!!!**!++   else
!!!**!++     aprB_ND(ja,jz,jnu) =zero
!!!**!++     tauB_ND(ja,jz,jnu)=zero
!!!**!++     wB_ND(ja,jz)=-hhuge
!!!**!++   end if
!!!**!++
!!!**!++   end do
!!!**!++  end do
!!!**!++
!!!**!++end if
!!!**
!!!**!13aug21
!!!**if(barg_offgrid.eq.1) then
!!!**
!!!**!write(outfile1,*) 'rtbis nu2 '
!!!**
!!!**  do jz=  1, nz
!!!**   do ja= 1, nA
!!!**     call aHexpB_ND_array_defi
!!!**     call tauB_ND_array_defi !13apr21
!!!**     call val_ND_array_defi !05may21
!!!**
!!!**  ! .. write out ..
!!!**  if((jz.eq.2).and.(ja.eq.32)) then
!!!**  open(297, file='nu2_ND_temp.dat')
!!!**  write(297,'(3a3,a5,x,4a14)') 'jnu','jz','ja', 'japr','apr', 'tau+qEH','tau',  'qEH', 'netval'
!!!**    do japr= 1, nA
!!!**    write(297,'(3i3,i5,x,5f14.6)') jnu,jz,ja, japr, Aj(japr), &
!!!**        & tauB_ND_array(japr)+q0*aHexpB_ND_array(japr), &
!!!**        & tauB_ND_array(japr), q0*aHexpB_ND_array(japr), val_ND_array(japr)
!!!**    end do
!!!**  close(297)
!!!**  end if
!!!**
!!!**   Atop=min(limit_Atop*delta*Aj(ja),Aj(nA))
!!!**   nAtop=min(count(Aj(1:nA).lt.Atop)+1,nA)
!!!**
!!!**   ! IF 1
!!!**   if(maxval(val_ND_array(1:nAtop)).gt.zero) then
!!!**     ishit1=maxloc(&
!!!**        &  tauB_ND_array(1:nAtop)+q0*aHexpB_ND_array(1:nAtop))
!!!**     locaprB_ND =ishit1(1)+1-1
!!!**!++     ! IF 2
!!!**     if(locaprB_ND.eq.nAtop) then   !14aug21
!!!**         ! IF 3
!!!**         if(val_ND_func(Atop).ge.zero) then
!!!**            aprB_ND(ja,jz,jnu)=Atop
!!!**            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!!!**!14aug21            wB_ND(ja,jz)=tauB_ND_array(locaprB_ND) &
!!!**!14aug21                &       +q0*aHexpB_ND_array(locaprB_ND)
!!!**            wB_ND(ja,jz)=lip(Aj(1:nA),       &          !14aug21: off the grid
!!!**             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
!!!**             &      aprB_ND(ja,jz,jnu))
!!!**         else
!!!**            aprlower=zero
!!!**            aprupper=Atop
!!!**            !pacc=0.00001_prec
!!!**            !pacc=0.0000001_prec
!!!**            aprB_ND(ja,jz,jnu)=rtbis(val_ND_func,aprlower,aprupper,bacc)
!!!**            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!!!**!            wB_ND(ja,jz)=tauB_ND_array(locaprB_ND) &
!!!**!                &       +q0*aHexpB_ND_array(locaprB_ND)
!!!**            wB_ND(ja,jz)=lip(Aj(1:nA),       &
!!!**             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
!!!**             &      aprB_ND(ja,jz,jnu))
!!!**         end if !IF 3
!!!**
!!!**
!!!**!++
!!!**     else                   !14aug21
!!!**        ! IF 3b
!!!**        if(val_ND_func(Aj(locaprB_ND)).ge.zero) then
!!!**            aprB_ND(ja,jz,jnu)=Aj(locaprB_ND)
!!!**            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!!!**            wB_ND(ja,jz)=lip(Aj(1:nA),       &
!!!**             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
!!!**             &      aprB_ND(ja,jz,jnu))
!!!**        else
!!!**            aprlower=zero
!!!**            aprupper=Aj(locaprB_ND)
!!!**            aprB_ND(ja,jz,jnu)=rtbis(val_ND_func,aprlower,aprupper,bacc)
!!!**            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!!!**            wB_ND(ja,jz)=lip(Aj(1:nA),       &
!!!**             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
!!!**             &      aprB_ND(ja,jz,jnu))
!!!**        end if ! IF 3b
!!!**
!!!**     end if !IF 2        !14aug21: end
!!!**!++
!!!**
!!!**
!!!**   else
!!!**     aprB_ND(ja,jz,jnu) =zero
!!!**     tauB_ND(ja,jz,jnu)=zero
!!!**     wB_ND(ja,jz)=-hhuge
!!!**   end if   !IF 1
!!!**
!!!**   end do
!!!**  end do
!!!**
!!!**end if
!!!**
!!!**
!!!**
!!!**
!!!**  ! .. write out ..
!!!**  open(297, file='barg_nu2_ND_fig.dat')
!!!**  write(297,'(2a3,a5,x,7a14)') 'jnu','jz','ja', 'a', 'tau','apr',  'aprold', 'erra','q', 'qb'
!!!**  do jnu= 2, 2
!!!**   do jz=  1, nz
!!!**    do ja= 1, nA
!!!**    qqq=lip(Aj(:),qqtil(:,jthetapr,jz,jnu),aprB_ND(ja,jz,jnu))
!!!**    write(297,'(2i3,i5,x,7f14.4)') jnu,jz,ja, Aj(ja), tauB_ND(ja,jz,jnu), &
!!!**        & aprB_ND(ja,jz,jnu), &
!!!**        & aprB_NDold(ja,jz), abs(aprB_ND(ja,jz,jnu)-aprB_NDold(ja,jz)), &
!!!**        & qqq, &
!!!**        & aprB_ND(ja,jz,jnu)*qqq
!!!**    end do
!!!**   end do
!!!**  end do
!!!**  close(297)
!!!**
!!!**
!!!** deallocate(tauB_ND_array,aHexpB_ND_array)
!!!** deallocate(aprB_NDold)
!!!** deallocate(val_ND_array)

 use interp
 implicit none
 integer :: jz, ja, jtheta, jthetapr, jnu
 integer, dimension(1)::ishit1
 real(prec),  allocatable ::  tauB_ND_array(:), aHexpB_ND_array(:)
 real(prec),  allocatable :: aprB_NDold(:,:)
 real(prec),  allocatable :: val_ND_array(:) !05may21
 integer :: jthetapr_aux, japr, jnupr
 integer :: locaprB_ND
 real(prec) :: ttau, yy, cons, vexp
 real(prec) :: qqq
 integer :: nAtop
 real(prec) :: aapr, aupper, alower
 real(prec) :: golden
 integer :: japrlower, japrupper
 !real(prec) pacc
 real(prec) rtbis
 integer :: errmess !26oct21
 real(prec) :: Atop, aprlower, aprupper
 real(prec) :: aprB_ND_max, valND_max
 real(prec) :: wB_ND_max

 external rtbis

 allocate(tauB_ND_array(1:nA), aHexpB_ND_array(1:nA))
 allocate(val_ND_array(1:nA)) !05may21
 allocate(aprB_NDold(1:nA,1:nz))


  jtheta=1
  jnu=2
  jthetapr=0

  aprB_NDold(1:nA,1:nz)=aprB_ND(1:nA,1:nz,jnu)

! --------------------
! On the grid
! --------------------
if(barg_offgrid.eq.0) then

  do jz=  1, nz
   do ja= 1, nA
     !call tauB_ND_array_defi
     call aHexpB_ND_array_defi
     call tauB_ND_array_defi !13apr21
     call val_ND_array_defi !05may21

  ! .. write out ..
  if((jz.eq.4).and.(ja.eq.2)) then
  open(297, file='nu2_ND_temp.dat')
  write(297,'(3a3,a5,x,4a14)') 'jnu','jz','ja', 'japr','apr', 'tau+qEH','tau',  'qEH', 'netval'
    do japr= 1, nA
    write(297,'(3i3,i5,x,5f14.6)') jnu,jz,ja, japr, Aj(japr), &
        & tauB_ND_array(japr)+q0*aHexpB_ND_array(japr), &
        & tauB_ND_array(japr), q0*aHexpB_ND_array(japr), val_ND_array(japr)
    end do
  close(297)
  end if



    ! .. Use restriction on lender's plans: can't get more that you are owed ..
!03jul21
   nAtop=count(Aj(1:nA).le.limit_Atop*delta*Aj(ja))
   !nAtop=nA !ja
   !nAtop=count(Aj(1:nA).le.2.5_prec*delta*Aj(ja))
   if(maxval(val_ND_array(1:nAtop)).ge.zero) then !05may21
     ishit1=maxloc(&
        &  tauB_ND_array(1:nAtop)+q0*aHexpB_ND_array(1:nAtop),val_ND_array(1:nAtop).ge.zero) !05may21
     locaprB_ND =ishit1(1)+1-1
     aprB_ND(ja,jz,jnu)=Aj(locaprB_ND)
     tauB_ND(ja,jz,jnu)=tauB_ND_array(locaprB_ND)
     wB_ND(ja,jz)=tauB_ND_array(locaprB_ND) &
            &       +q0*aHexpB_ND_array(locaprB_ND)
!06jul21
!    ! .. if off-grid maximisation ..
!      if((locaprB_ND.lt.nA).and.(locaprB_ND.gt.1)   &
!        &   .and.(val_ND_array(locaprB_ND+1).ge.zero)) then
!        ! Bracket interval:
!        alower=Aj(locaprB_ND-1)
!        if(val_ND_array(locaprB_ND+1).ge.zero) then
!          aupper=Aj(locaprB_ND+1)
!        else ! .. need to find bound via linear interpolation ..
!          aupper=Aj(locaprB_ND+1)    &
!            &   -(Aj(locaprB_ND+1)-Aj(locaprB_ND)) &
!            &   *val_ND_array(locaprB_ND)  &
!            &       /(val_ND_array(locaprB_ND)-val_ND_array(locaprB_ND+1))
!        end if
!        ! Optimise new function on continuum negat_wB_ND_c
!        wB_ND(ja,jz)=-golden( &
!         &   alower,Aj(locaprB_ND),aupper, &
!         &   negat_wB_ND_c, tol0_offgridND,  aapr)
!      end if
!        aprB_ND(ja,jz,jnu) = aapr
!        tauB_ND(ja,jz,jnu)=aapr/delta
   else
     aprB_ND(ja,jz,jnu) =zero
     tauB_ND(ja,jz,jnu)=zero
     wB_ND(ja,jz)=-hhuge
     !wB_ND(ja,jz)=wB_D(ja,jz)-small !12jun21
   end if

!   if(maxval(val_ND_array).ge.zero) then !05may21
!     ishit1=maxloc(&
!        &  tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA),val_ND_array(1:nA).ge.zero) !05may21
!     locaprB_ND(ja,jz,jnu) =ishit1(1)+1-1
!     tauB_ND(ja,jz,jnu)=tauB_ND_array(locaprB_ND(ja,jz,jnu))
!     wB_ND(ja,jz)=tauB_ND_array(locaprB_ND(ja,jz,jnu)) &
!            &       +q0*aHexpB_ND_array(locaprB_ND(ja,jz,jnu))
!   else
!     locaprB_ND(ja,jz,jnu) =nAzero
!     tauB_ND(ja,jz,jnu)=zero
!     wB_ND(ja,jz)=-hhuge
!     !wB_ND(ja,jz)=wB_D(ja,jz)-small !12jun21
!   end if


     !13apr21
    if(barg_option.eq.1) then
     jthetapr_aux=0
     japr=locaprB_ND
     aprB_ND(ja,jz,jnu)=Aj(japr)
     ttau=tauB_ND(ja,jz,jnu)
     yy=zj(jz)*psi(jtheta,jz)
     cons=yy-ttau
     vexp=zero
     do jnupr=1,nnu
      vexp=vexp+pinu(jnu,jnupr)*sum(piz(jz,:)*vv(japr,jthetapr_aux,:,jnupr))
     end do
      vB_ND_nu2(ja,jz)=utt(cons)+beta*vexp
    end if

   end do
  end do

end if


! --------------------
! Off the grid
! --------------------


!13aug21
if(barg_offgrid.eq.1) then

!write(outfile1,*) 'rtbis nu2 '

  do jz=  1, nz
   do ja= 1, nA
     call aHexpB_ND_array_defi
     call tauB_ND_array_defi !13apr21
     call val_ND_array_defi !05may21

  ! .. write out ..
  if((jz.eq.2).and.(ja.eq.32)) then
  open(297, file='nu2_ND_temp.dat')
  write(297,'(3a3,a5,x,4a14)') 'jnu','jz','ja', 'japr','apr', 'tau+qEH','tau',  'qEH', 'netval'
    do japr= 1, nA
    write(297,'(3i3,i5,x,5f14.6)') jnu,jz,ja, japr, Aj(japr), &
        & tauB_ND_array(japr)+q0*aHexpB_ND_array(japr), &
        & tauB_ND_array(japr), q0*aHexpB_ND_array(japr), val_ND_array(japr)
    end do
  close(297)
  end if

   Atop=min(limit_Atop*delta*Aj(ja),Aj(nA))
   nAtop=min(count(Aj(1:nA).lt.Atop)+1,nA)

   ! IF 1
   if(maxval(val_ND_array(1:nAtop)).gt.zero) then
     ishit1=maxloc(&
        &  tauB_ND_array(1:nAtop)+q0*aHexpB_ND_array(1:nAtop))
     locaprB_ND =ishit1(1)+1-1
!++     ! IF 2
     if(locaprB_ND.eq.nAtop) then   !14aug21
         ! IF 3
         if(val_ND_func(Atop).ge.zero) then
            aprB_ND(ja,jz,jnu)=Atop
            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!14aug21            wB_ND(ja,jz)=tauB_ND_array(locaprB_ND) &
!14aug21                &       +q0*aHexpB_ND_array(locaprB_ND)
            wB_ND(ja,jz)=lip(Aj(1:nA),       &          !14aug21: off the grid
             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
             &      aprB_ND(ja,jz,jnu))
         else
            aprlower=zero
            aprupper=Atop
            !pacc=0.00001_prec
            !pacc=0.0000001_prec
            aprB_ND(ja,jz,jnu)=rtbis(val_ND_func,aprlower,aprupper,bacc,errmess)
            if(errmess.eq.1) then !26oct21
                write(*,*) 'rtbis bracketing err in [barg_nu2_ND] '
                stop
            end if
            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!            wB_ND(ja,jz)=tauB_ND_array(locaprB_ND) &
!                &       +q0*aHexpB_ND_array(locaprB_ND)
            wB_ND(ja,jz)=lip(Aj(1:nA),       &
             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
             &      aprB_ND(ja,jz,jnu))
         end if !IF 3


!++
     else                   !14aug21


!find optimal off the grid
!27oct21
        if(  (locaprB_ND.gt.1).and.(locaprB_ND.lt.nAtop).and. &
             (-negat_wB_ND_c(Aj(locaprB_ND)).gt.-negat_wB_ND_c(Aj(locaprB_ND+1))).and. &
             (-negat_wB_ND_c(Aj(locaprB_ND)).gt.-negat_wB_ND_c(Aj(locaprB_ND-1))) ) then
            wB_ND_max=-golden( &
                & Aj(locaprB_ND-1), &
                & Aj(locaprB_ND), Aj(locaprB_ND+1), &
                &   negat_wB_ND_c, tol0_offgridND,  aprB_ND_max)
            valND_max=val_ND_func(aprB_ND_max)  !27oct21
        else
            aprB_ND_max=Aj(locaprB_ND)
            valND_max=val_ND_func(aprB_ND_max)
        end if

        ! IF 3b
        if(valND_max.ge.zero) then          !16aug21
            aprB_ND(ja,jz,jnu)=aprB_ND_max  !16aug21
            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
            wB_ND(ja,jz)=lip(Aj(1:nA),       &
             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
             &      aprB_ND(ja,jz,jnu))
        else
            aprlower=zero
            aprupper=aprB_ND_max            !16aug21
!                !17aug21
!                japrlower=1
!                do japrlower=locaprB_ND, 1, -1
!                    if (val_ND_func(Aj(japrlower)).gt.zero) exit
!                end do
!                aprlower=Aj(japrlower)
            aprB_ND(ja,jz,jnu)=rtbis(val_ND_func,aprlower,aprupper,bacc,errmess)  !26oct21
            if(errmess.eq.1) then !26oct21
                write(*,*) 'rtbis bracketing err in [barg_nu2_ND] II'
                write(*,*) 'aprlower,aprupper,amax ', aprlower,aprupper,aprB_ND_max
                write(*,*) 'vlower,vupper,vmax ', val_ND_func(aprlower),val_ND_func(aprupper),val_ND_func(aprB_ND_max)
                stop
            end if
            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
            wB_ND(ja,jz)=lip(Aj(1:nA),       &
             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
             &      aprB_ND(ja,jz,jnu))
        end if ! IF 3b

     end if !IF 2        !14aug21: end
!++
!!!16aug21: find optimal off the grid
!!        !16aug21
!!        if(  (locaprB_ND.gt.1).and.(locaprB_ND.lt.nAtop).and. &
!!             (val_ND_func(Aj(locaprB_ND)).gt.val_ND_func(Aj(locaprB_ND+1))).and. &
!!             (val_ND_func(Aj(locaprB_ND)).gt.val_ND_func(Aj(locaprB_ND-1))) ) then
!!            valND_max=-golden( &
!!                & Aj(locaprB_ND-1), &
!!                & Aj(locaprB_ND), Aj(locaprB_ND+1), &
!!                &   negat_valND_func, tol0_offgridND,  aprB_ND_max)
!!        else
!!            aprB_ND_max=Aj(locaprB_ND)
!!            valND_max=val_ND_func(aprB_ND_max)
!!        end if
!!
!!        ! IF 3b
!!        if(valND_max.ge.zero) then          !16aug21
!!            aprB_ND(ja,jz,jnu)=aprB_ND_max  !16aug21
!!            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!!            wB_ND(ja,jz)=lip(Aj(1:nA),       &
!!             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
!!             &      aprB_ND(ja,jz,jnu))
!!        else
!!            aprlower=zero
!!            aprupper=aprB_ND_max            !16aug21
!!!                !17aug21
!!!                japrlower=1
!!!                do japrlower=locaprB_ND, 1, -1
!!!                    if (val_ND_func(Aj(japrlower)).gt.zero) exit
!!!                end do
!!!                aprlower=Aj(japrlower)
!!            aprB_ND(ja,jz,jnu)=rtbis(val_ND_func,aprlower,aprupper,bacc,errmess)  !26oct21
!!            if(errmess.eq.1) then !26oct21
!!                write(*,*) 'rtbis bracketing err in [barg_nu2_ND] II'
!!                write(*,*) 'aprlower,aprupper,amax ', aprlower,aprupper,aprB_ND_max
!!                write(*,*) 'vlower,vupper,vmax ', val_ND_func(aprlower),val_ND_func(aprupper),val_ND_func(aprB_ND_max)
!!                stop
!!            end if
!!            tauB_ND(ja,jz,jnu)=aprB_ND(ja,jz,jnu)/delta
!!            wB_ND(ja,jz)=lip(Aj(1:nA),       &
!!             &   tauB_ND_array(1:nA)+q0*aHexpB_ND_array(1:nA), &
!!             &      aprB_ND(ja,jz,jnu))
!!        end if ! IF 3b
!!
!!     end if !IF 2        !14aug21: end
!!!++


   else
     aprB_ND(ja,jz,jnu) =zero
     tauB_ND(ja,jz,jnu)=zero
     wB_ND(ja,jz)=-hhuge
   end if   !IF 1

   end do
  end do

end if




  ! .. write out ..
  open(297, file='barg_nu2_ND_fig.dat')
  write(297,'(2a3,a5,x,7a14)') 'jnu','jz','ja', 'a', 'tau','apr',  'aprold', 'erra','q', 'qb'
  do jnu= 2, 2
   do jz=  1, nz
    do ja= 1, nA
    qqq=lip(Aj(:),qqtil(:,jthetapr,jz,jnu),aprB_ND(ja,jz,jnu))
    write(297,'(2i3,i5,x,7f14.4)') jnu,jz,ja, Aj(ja), tauB_ND(ja,jz,jnu), &
        & aprB_ND(ja,jz,jnu), &
        & aprB_NDold(ja,jz), abs(aprB_ND(ja,jz,jnu)-aprB_NDold(ja,jz)), &
        & qqq, &
        & aprB_ND(ja,jz,jnu)*qqq
    end do
   end do
  end do
  close(297)


 deallocate(tauB_ND_array,aHexpB_ND_array)
 deallocate(aprB_NDold)
 deallocate(val_ND_array)




 contains
 !------------------------------------------------------------------
 !16aug21
 function negat_valND_func(aprdum)
 implicit none
 real(prec) :: aprdum
 real(prec) :: negat_valND_func
    negat_valND_func=val_ND_func(aprdum)
 end function negat_valND_func
 !------------------------------------------------------------------

 !------------------------------------------------------------------
 function val_ND_func(aprdum)
 implicit none
 real(prec) :: aprdum
 real(prec) :: val_ND_func
    val_ND_func=lip(Aj(1:nAtop),val_ND_array(1:nAtop),aprdum)
 end function val_ND_func
 !------------------------------------------------------------------
 function negat_wB_ND_c(aadum)
 use interp
 implicit none
 real(prec) :: aadum, negat_wB_ND_c
    negat_wB_ND_c=-lip(Aj(:),tauB_ND_array(:)+q0*aHexpB_ND_array(:),aadum)
 end function negat_wB_ND_c
 !------------------------------------------------------------------
!05may21
 subroutine tauB_ND_array_defi
 implicit none
 integer :: japr
 do japr=1, nA
  tauB_ND_array(japr)=Aj(japr)/delta
 end do
 end subroutine tauB_ND_array_defi
 !------------------------------------------------------------------
!05may21
 subroutine val_ND_array_defi
 implicit none
 integer :: japr, jnupr
 integer :: jthetapr0, jthetapr1
 real(prec) :: auxterm, yy, cons0, cons1, vexp0, vexp1
 real(prec) :: tau

!+++
!+++  if((jz.eq.2).and.(ja.eq.23)) then
!+++  open(297, file='nu2_ND_temp2.dat')
!+++  write(297,'(3a3,a5,x,6a14)') 'jnu','jz','ja', 'japr','apr', 'netval', &
!+++        & 'u0', 'Ev0', 'u1', 'Ev1'

  do japr=1, nA
    yy=zj(jz)*psi(jtheta,jz)
    tau=Aj(japr)/delta
    cons0=yy-tau
    cons1=yy
    jthetapr0=0
    jthetapr1=1
    vexp0=zero
    vexp1=zero
    do jnupr=1,nnu
     vexp0=vexp0+pinu(jnu,jnupr) &
      & *sum(piz(jz,:)*vv(japr,jthetapr0,:,jnupr))
     vexp1=vexp1+pinu(jnu,jnupr) &
      & *sum(piz(jz,:)*vv(ja,jthetapr1,:,jnupr))
!if(jnupr.eq.1) vexp0=vexp0+sum(piz(jz,:)*vv(japr,jthetapr0,:,jnupr))
!if(jnupr.eq.2) vexp0=vexp0
!if(jnupr.eq.1) vexp1=vexp1+sum(piz(jz,:)*vv(japr,jthetapr1,:,jnupr))
!if(jnupr.eq.2) vexp1=vexp1
    end do
    val_ND_array(japr)=utt(cons0)+beta*vexp0-(utt(cons1)+beta*vexp1)
!+++    write(297,'(3i3,i5,x,6f14.6)') jnu,jz,ja, japr, Aj(japr), &
!+++         &   val_ND_array(japr), utt(cons0), vexp0, utt(cons1), vexp1
  end do
!+++


  close(297)
!+++  end if


 end subroutine val_ND_array_defi

 !------------------------------------------------------------------
!! subroutine tauB_ND_array_defi
!!!
!!! Global: sigma beta piz pinu nA zj vv
!!!
!!! Global (host): jz jtheta jnu tauB_ND_array
!!!
!!! Local: japr jnupr auxterm
!!!        yy cons1 jthetapr0 jthetapr1 vexp0 vexp1
!!!
!!! dependencies: func psi utt
!!
!! implicit none
!! integer :: japr, jnupr
!! real(prec) :: auxterm, yy, cons1, jthetapr0, jthetapr1, vexp0, vexp1
!!
!! do japr=1, nA
!!    yy=zj(jz)*psi(jtheta,jz)
!!    cons1=yy
!!    jthetapr0=0
!!    jthetapr1=1
!!    vexp0=zero
!!    vexp1=zero
!!    do jnupr=1,nnu
!!     vexp0=vexp0+pinu(jnu,jnupr) &
!!      & *sum(piz(jz,:)*vv(japr,jthetapr0,:,jnupr))
!!     vexp1=vexp1+pinu(jnu,jnupr) &
!!      & *sum(piz(jz,:)*vv(ja,jthetapr1,:,jnupr))
!!!      & *sum(piz(jz,:)*vv(japr,jthetapr1,:,jnupr))  ! SHOULD HAVE ja and not japr!!
!!    end do
!!
!!    auxterm=(utt(cons1)+beta*vexp1-beta*vexp0)*(one-sigma)
!!    tauB_ND_array(japr)=yy-auxterm**(one/(one-sigma))
!!
!!!!    if(tauB_ND_array(japr).gt.Aj(ja)) tauB_ND_array(japr)=Aj(ja) !13apr21
!!
!!!13apr21
!! if(barg_option.eq.2) then
!!!    if(tauB_ND_array(japr)+q0*aHexpB_ND_array(japr).gt.Aj(ja)*qqtil(ja,jthetapr,jz,jnu)) then
!!!        tauB_ND_array(japr)=-q0*aHexpB_ND_array(japr)+Aj(ja)*qqtil(ja,jthetapr,jz,jnu)
!!    if(tauB_ND_array(japr)+q0*aHexpB_ND_array(japr).gt.Aj(ja)/(one-q0*delta)) then
!!        tauB_ND_array(japr)=-q0*aHexpB_ND_array(japr)+Aj(ja)/(one-q0*delta)
!!    end if
!! end if
!!
!! end do
!!
!! end subroutine tauB_ND_array_defi
 !------------------------------------------------------------------
 subroutine aHexpB_ND_array_defi
!
! Global: nA nnu pinu piz Aj
!         HH
!
! Global (host): jtheta jnu jz
!                aHexpB_ND_array
!
! Local: japr sum_aux jnupr
!
 implicit none
 integer :: japr, jnupr
 real(prec) :: sum_aux

 do japr=1, nA
   sum_aux=zero
   do jnupr=1,nnu
    sum_aux=sum_aux+pinu(jnu,jnupr) &
      & *sum(piz(jz,:)*HH(japr,jthetapr,:,jnupr))
   end do
   aHexpB_ND_array(japr)=Aj(japr)*sum_aux
 end do

 end subroutine aHexpB_ND_array_defi

 !------------------------------------------------------------------
 end subroutine barg_nu2_ND

!*************************************************************
 subroutine barg_nu2_D
!
! Global: nz nA nnu pinu piz vv
!         wB_D
!
! Local: jnu jtheta jthetapr jz ja japr jnupr
!        wexpBD
 implicit none
 integer :: jnu, jtheta, jthetapr, jz, ja, japr, jnupr
 real(prec) :: wexpBD
 integer :: jthetapr_aux
 real(prec) :: yy, cons, vexp
   jnu=2
   jtheta=1
   jthetapr=1
   do jz=  1, nz
    do ja= 1, nA
     japr=ja
     wexpBD=zero
     do jnupr=1,nnu
      wexpBD=wexpBD+pinu(jnu,jnupr)*sum(piz(jz,:)*HH(japr,jthetapr,:,jnupr))
!if(jnupr.eq.1) wexpBD=wexpBD+sum(piz(jz,:)*HH(japr,jthetapr,:,jnupr))
!if(jnupr.eq.2) wexpBD=wexpBD
     end do
      wB_D(ja,jz)=Aj(japr)*q0*wexpBD

     !13apr21
    if(barg_option.eq.1) then
     jthetapr_aux=1
     japr=ja
     yy=zj(jz)*psi(jtheta,jz)
     cons=yy
     vexp=zero
     do jnupr=1,nnu
      vexp=vexp+pinu(jnu,jnupr)*sum(piz(jz,:)*vv(japr,jthetapr_aux,:,jnupr))
     end do
      vB_D_nu2(ja,jz)=utt(cons)+beta*vexp
    end if

    end do
   end do
 end subroutine barg_nu2_D

!*************************************************************
 subroutine barg_agentval
! Locals: jnu jz jtheta ja
!         thetapr aapr cons d01 prob
!         vv_aux
!
! Globals:  nnu nz  nA zj piz beta
!           TT AA
!           vv (OUT)
! Dependencies: use interp
!               function utt psi vexp_theta1_c
!
 use interp
 implicit none
 integer :: jnu,jz,jtheta,ja,jthetapr, d01
 real(prec) :: aapr, cons, prob
 real(prec),  allocatable ::  vv_aux(:,:,:)

!28jun21
 real(prec), allocatable :: vv2d(:,:,:)
 real(prec) :: natspli

 allocate ( vv_aux(1:nA,1:nz,1:nnu) )
!28jun21
 allocate ( vv2d(1:nA,1:nz,1:nnu))

!28jun21
    if(interp_NDv.eq.2) then
    ! .. build spline for vv ..
    natspli=1.0E30_prec+small
    jtheta=1
    do jnu= 1, nnu
     do jz=  1, nz
      call spline(Aj(1:nA),vv(1:nA,jtheta,jz,jnu),natspli,natspli,vv2d(1:nA,jz,jnu))
     end do
    end do
    end if

 jtheta=1
 do jnu=1, nnu
  do jz = 1, nz
   do ja=1,nA
      !case: no recovery; excluded forever
      !!vv(ja,jtheta,jz,jnu)=utt(zj(jz)*psi(jtheta,jz))+beta*sum(piz(jz,:)*vv(ja,jtheta,:,jnu))
      !d01=1
      !cons=zj(jz)*psi(jtheta,jz)-TT(ja,jtheta,jz,jnu,d01)
      !aapr=AA(ja,jtheta,jz,jnu,d01)
      !jthetapr=1
      !vv(ja,jtheta,jz,jnu)=utt(cons)+beta*vexp_theta1_c(aapr)

      vv_aux(ja,jz,jnu)=zero
      do d01=0,1
       jthetapr=d01
       cons=zj(jz)*psi(jtheta,jz)-TT(ja,jtheta,jz,jnu,d01)
       aapr=AA(ja,jtheta,jz,jnu,d01)
       if(d01.eq.0) prob=one-DEF(ja,jtheta,jz,jnu)
       if(d01.eq.1) prob=DEF(ja,jtheta,jz,jnu)
       vv_aux(ja,jz,jnu)=vv_aux(ja,jz,jnu)     &
        & + prob*(utt(cons)+beta*vexp_theta1_c(aapr))
      end do


      !case: exog recovery kappa; instant return
      !aapr=kappa*Aj(ja)
      !jthetapr=0
      !vv(ja,jtheta,jz,jnu)=utt(zj(jz)*psi(jtheta,jz))+beta*vexp_theta1_c(aapr)
   end do
  end do
 end do

    vv_temp(:,jtheta,:,:)=vv_aux(:,:,:)

 deallocate(vv_aux)
 deallocate (vv2d)
 contains
!-----------------------------------------------------------------------
  function vexp_theta1_c(apr)
! Globals: nnu nz
!
! Globals (host barg_agentval): jthetapr jz jnu
!
! Locals: jnupr jzpr
!         vinterp apr
!         vexp_theta1_c (OUT)
!
! Dependencies: function vvinterp
!
    implicit none
    real(prec) :: apr, vexp_theta1_c, vinterp
    integer :: jnupr, jzpr

      vexp_theta1_c=zero
      do jnupr=1,nnu
       do jzpr=1, nz
       vinterp=vvinterp(apr,jthetapr,jzpr,jnupr)
       vexp_theta1_c=vexp_theta1_c+pinu(jnu,jnupr)*piz(jz,jzpr)*vinterp
!if(jnupr.eq.1) vexp_theta1_c=vexp_theta1_c+piz(jz,jzpr)*vinterp
!if(jnupr.eq.2) vexp_theta1_c=vexp_theta1_c
       end do
      end do

  end function vexp_theta1_c
!-----------------------------------------------------------------------
  function vvinterp(aapr,jthetapr,jzpr,jnupr)
  implicit none
! Globals: Aj
!          vv
!
! Globals (host agentND_opt): vvinterp (OUT)
!
! Local: aapr jthetapr jzpr jnupr
!        apr
!        japrlow, japrup
!        vtemp_ND vtemp_D
!
! Dependencies: lip
!
  real(prec), intent(in) :: aapr
  integer, intent(in)    :: jthetapr, jzpr, jnupr
  real(prec) :: apr
  integer    :: japrlow, japrup
  real(prec) :: vtemp_ND, vtemp_D
  real(prec) :: vvinterp

  apr=max(Aj(1), aapr)
  apr=min(Aj(na), apr)
  japrlow=count(Aj.le.apr)
  japrup=min(japrlow+1,nA)

  if(interp_theta1v.eq.1) &
    & vvinterp=lip(Aj(:),vv(:,jthetapr,jzpr,jnupr),apr)

!28jun21
  if(interp_theta1v.eq.2) &
    & vvinterp=splint(Aj(1:nA),vv(1:nA,jthetapr,jzpr,jnupr),vv2d(1:nA,jzpr,jnupr),apr)

  end function vvinterp
!-----------------------------------------------------------------------
 end subroutine barg_agentval
!*************************************************************
 subroutine update_agentval
 implicit none
 real(prec),  allocatable ::  vvold(:,:,:,:)
 integer :: jnu, jz, jtheta, ja
 allocate (vvold(1:nA,0:ntheta,1:nz,1:nnu))

    vvold(:,:,:,:)=vv(:,:,:,:)
    vv(:,:,:,:)=vv_temp(:,:,:,:)

    errmaxV=maxval(abs(vv(1:nA,0:ntheta,1:nz,1:nnu)-vvold(1:nA,0:ntheta,1:nz,1:nnu)))
    vv(:,:,:,:)=speed_adjv*vv(:,:,:,:)+(one-speed_adjv)*vvold(:,:,:,:)

open(297, file='V_thet0_fig.dat')
write(297,'(3a3,a5,x,4a8)') 'jnu', 'jth','jz','ja',    &
           &   'a', 'V ', 'Vold ', 'diffV'
do jnu=1, nnu
 do jtheta=0, 0
  do jz = 1, nz
   do ja=1,nA
    write(297,'(3i3,i5,x,f8.3,f8.3,f8.3,f8.3)') jnu,jtheta,jz,ja,    &
           &   Aj(ja), &
           &   vv_temp(ja,jtheta,jz,jnu), vvold(ja,jtheta,jz,jnu), &
           &   abs(vv_temp(ja,jtheta,jz,jnu)- vvold(ja,jtheta,jz,jnu))
   end do
  end do
 end do
end do
close(297)
open(297, file='V_thet1_fig.dat')
write(297,'(3a3,a5,x,4a8)') 'jnu', 'jth','jz','ja',    &
           &   'a', 'V ', 'Vold ', 'diffV'
do jnu=1, nnu
 do jtheta=0, 0
  do jz = 1, nz
   do ja=1,nA
    write(297,'(3i3,i5,x,f8.3,f8.3,f8.3,f8.3)') jnu,jtheta,jz,ja,    &
           &   Aj(ja), &
           &   vv_temp(ja,jtheta,jz,jnu), vvold(ja,jtheta,jz,jnu), &
           &   abs(vv_temp(ja,jtheta,jz,jnu)- vvold(ja,jtheta,jz,jnu))
   end do
  end do
 end do
end do
close(297)

 deallocate(vvold)

 end subroutine update_agentval


!*************************************************************
! adapted to EV shocks in bargaining
!*************************************************************
! ***********************************************************
 !15jun21
  subroutine barg_nu1_EVshocks
 !
 ! Local: jtheta jnu ja jz
 !        DEFold
 !
 ! Globals:  Aj
 !           vB_ND vB_D locaprB_ND tauB_ND
 !           DEF TT AA
 !
     implicit none
     integer :: jtheta, jnu, ja, jz
     real(prec),  allocatable ::  DEFold(:,:)

     real(prec) :: u_aux, termD, termND !15jun21

     allocate(DEFold(1:nA,1:nz))

     jtheta=1
     jnu=1
     DEFold(1:nA,1:nz)=DEF(1:nA,jtheta,1:nz,jnu)

 if((barg_option.eq.0).or.(barg_option.eq.2)) then
 !13apr21: coment in if flag does not apply
  do ja=1, nA
   do jz=1, nz
      u_aux=sigEV_B_nu1*log(scaleuEV)-max(vB_D(ja,jz),vB_ND(ja,jz))
      termD=exp((vB_D(ja,jz)+u_aux)/sigEV_B_nu1)
      termND=exp((vB_ND(ja,jz)+u_aux)/sigEV_B_nu1)
      vv_temp(ja,jtheta,jz,jnu)=-sigEV_B_nu1*log(two)+sigEV_B_nu1*log(termND+termD)-u_aux
      DEF(ja,jtheta,jz,jnu)=termD/(termD+termND)
!      DEF(ja,jtheta,jz,jnu)=zero !15aug21
!      vv_temp(ja,jtheta,jz,jnu)=vB_ND(ja,jz) !15aug21
      AA(ja,jtheta,jz,jnu,0)=aprB_ND(ja,jz,jnu)
   end do
  end do
  TT(:,jtheta,:,jnu,0)=tauB_ND(:,:,jnu)
 end if

     open(297, file='DEF_barg_nu1_fig.dat')
     write(297,'(3a3,a5,x,4a8,2a12)') 'jnu', 'jth','jz','ja', 'a',   &
                &   'DEF ', 'DEFold ', 'diffD', 'vB_ND', 'vB_D'
       do jz = 1, nz
        do ja=1,nA
         write(297,'(3i3,i5,x,4f8.4,2f12.8)') jnu,jtheta,jz,ja,    &
                &   Aj(ja), &
                &   DEF(ja,jtheta,jz,jnu), DEFold(ja,jz), &
                &   abs(DEF(ja,jtheta,jz,jnu)- DEFold(ja,jz)), &
                &   vB_ND(ja,jz), vB_D(ja,jz)
        end do
       end do
     close(297)

     deallocate(DEFold)

  end subroutine barg_nu1_EVshocks

 ! ***********************************************************
 !15jun21
  subroutine barg_nu2_EVshocks
 !
 ! Local: jtheta jnu ja jz
 !        DEFold
 !
 ! Globals:  Aj
 !           wB_ND wB_D locaprB_ND tauB_ND
 !           DEF TT AA
 !
     use interp
     implicit none
     integer :: jtheta, jnu, ja, jz
     real(prec),  allocatable ::  DEFold(:,:)
     real(prec) :: vaux

     real(prec) :: u_aux, termD, termND !15jun21

     integer :: jthetapr, d01
     real(prec) :: aapr, cons, prob
     real(prec),  allocatable ::  vv_aux(:,:)

     allocate ( vv_aux(1:nA,1:nz) )
     allocate(DEFold(1:nA,1:nz))

     jtheta=1
     jnu=2
     DEFold(1:nA,1:nz)=DEF(1:nA,jtheta,1:nz,jnu)

 !13apr21: comment in if flag does not apply
 if((barg_option.eq.0).or.(barg_option.eq.2)) then
     !TT(:,jtheta,:,jnu,0)=tauB_ND(:,:,jnu)
     !AA(:,jtheta,:,jnu,0)=aprB_ND(:,:,jnu)
     do ja=1, nA
      do jz=1, nz
      u_aux=sigEV_B_nu2*log(scaleuEV)-max(wB_D(ja,jz),wB_ND(ja,jz))
      termD=exp((wB_D(ja,jz)+u_aux)/sigEV_B_nu2)
      termND=exp((wB_ND(ja,jz)+u_aux)/sigEV_B_nu2)
      DEF(ja,jtheta,jz,jnu)=termD/(termD+termND)
!      DEF(ja,jtheta,jz,jnu)=zero !15aug21
      AA(ja,jtheta,jz,jnu,0)=aprB_ND(ja,jz,jnu)
      TT(ja,jtheta,jz,jnu,0)=tauB_ND(ja,jz,jnu)

      !15jun21
      vv_aux(ja,jz)=zero
       do d01=0,1
        jthetapr=d01
        cons=zj(jz)*psi(jtheta,jz)-TT(ja,jtheta,jz,jnu,d01)
        aapr=AA(ja,jtheta,jz,jnu,d01)
        if(d01.eq.0) prob=one-DEF(ja,jtheta,jz,jnu)
        if(d01.eq.1) prob=DEF(ja,jtheta,jz,jnu)
        vv_aux(ja,jz)=vv_aux(ja,jz)     &
         & + prob*(utt(cons)+beta*vexp_theta1_c(aapr))
       end do

      end do
     end do
!++     TT(:,jtheta,:,jnu,0)=tauB_ND(:,:,jnu)
     vv_temp(:,jtheta,:,jnu)=vv_aux(:,:)
 end if

     open(297, file='DEF_barg_nu2_fig.dat')
     write(297,'(3a3,a5,x,4a8,2a12)') 'jnu', 'jth','jz','ja', 'a',   &
                &   'DEF ', 'DEFold ', 'diffD', 'wB_ND', 'wB_D '
       do jz = 1, nz
        do ja=1,nA
         write(297,'(3i3,i5,x,4f8.4,2f12.8)') jnu,jtheta,jz,ja,    &
                &   Aj(ja), &
                &   DEF(ja,jtheta,jz,jnu), DEFold(ja,jz), &
                &   abs(DEF(ja,jtheta,jz,jnu)- DEFold(ja,jz)), &
                &    wB_ND(ja,jz), wB_D(ja,jz)
        end do
       end do
     close(297)

     deallocate(DEFold)

 contains
!-----------------------------------------------------------------------
  function vexp_theta1_c(apr)
! Globals: nnu nz
!
! Globals (host barg_agentval): jthetapr jz jnu
!
! Locals: jnupr jzpr
!         vinterp apr
!         vexp_theta1_c (OUT)
!
! Dependencies: function vvinterp
!
    implicit none
    real(prec) :: apr, vexp_theta1_c, vinterp
    integer :: jnupr, jzpr

      vexp_theta1_c=zero
      do jnupr=1,nnu
       do jzpr=1, nz
       vinterp=vvinterp(apr,jthetapr,jzpr,jnupr)
       vexp_theta1_c=vexp_theta1_c+pinu(jnu,jnupr)*piz(jz,jzpr)*vinterp
!if(jnupr.eq.1) vexp_theta1_c=vexp_theta1_c+piz(jz,jzpr)*vinterp
!if(jnupr.eq.2) vexp_theta1_c=vexp_theta1_c
       end do
      end do

  end function vexp_theta1_c
!-----------------------------------------------------------------------
  function vvinterp(aapr,jthetapr,jzpr,jnupr)
  implicit none
! Globals: Aj
!          vv
!
! Globals (host agentND_opt): vvinterp (OUT)
!
! Local: aapr jthetapr jzpr jnupr
!        apr
!        japrlow, japrup
!        vtemp_ND vtemp_D
!
! Dependencies: lip
!
  real(prec), intent(in) :: aapr
  integer, intent(in)    :: jthetapr, jzpr, jnupr
  real(prec) :: apr
  integer    :: japrlow, japrup
  real(prec) :: vtemp_ND, vtemp_D
  real(prec) :: vvinterp

  apr=max(Aj(1), aapr)
  apr=min(Aj(na), apr)
  japrlow=count(Aj.le.apr)
  japrup=min(japrlow+1,nA)

!  if(interp_theta1v.eq.1) &
!    & vvinterp=lip(Aj(:),vv(:,jthetapr,jzpr,jnupr),apr)

  vvinterp=lip(Aj(:),vv(:,jthetapr,jzpr,jnupr),apr)

  end function vvinterp
!-----------------------------------------------------------------------

  end subroutine barg_nu2_EVshocks



!!* !02jun21
!!*  subroutine barg_nu1
!!* !
!!* ! Local: jtheta jnu ja jz
!!* !        DEFold
!!* !
!!* ! Globals:  Aj
!!* !           vB_ND vB_D locaprB_ND tauB_ND
!!* !           DEF TT AA
!!* !
!!*     implicit none
!!*     integer :: jtheta, jnu, ja, jz
!!*     real(prec),  allocatable ::  DEFold(:,:)
!!*
!!*     real(prec) :: u_aux, termD, termND !02jun21
!!*
!!*     allocate(DEFold(1:nA,1:nz))
!!*
!!*     jtheta=1
!!*     jnu=1
!!*     DEFold(1:nA,1:nz)=DEF(1:nA,jtheta,1:nz,jnu)
!!*
!!* if((barg_option.eq.0).or.(barg_option.eq.2)) then
!!* !13apr21: coment in if flag does not apply
!!*  do ja=1, nA
!!*   do jz=1, nz
!!* !02jun21    if(vB_ND(ja,jz).ge.vB_D(ja,jz)) then
!!* !02jun21     DEF(ja,jtheta,jz,jnu)=zero
!!* !02jun21    else
!!* !02jun21     DEF(ja,jtheta,jz,jnu)=one
!!* !02jun21    end if
!!*      u_aux=sigEV*log(scaleuEV)-max(vB_D(ja,jz),vB_ND(ja,jz)) !02jun21
!!*      termD=exp((vB_D(ja,jz)+u_aux)/sigEV)
!!*      termND=exp((vB_ND(ja,jz)+u_aux)/sigEV)
!!*      vv_temp(ja,jtheta,jz,jnu)=sigEV*log(termND+termD)-u_aux
!!*      DEF(ja,jtheta,jz,jnu)=termD/(termD+termND)             !02jun21
!!*
!!*      AA(ja,jtheta,jz,jnu,0)=Aj(locaprB_ND(ja,jz,jnu))
!!*   end do
!!*  end do
!!*  TT(:,jtheta,:,jnu,0)=tauB_ND(:,:,jnu)
!!*  !!TT(:,jtheta,:,jnu,0)=zero !14apr21  TEMP arrang
!!* end if
!!*
!!* !13apr21
!!* if(barg_option.eq.1) then
!!*  do ja=1, nA
!!*   do jz=1, nz
!!*    if(max(vB_ND(ja,jz),vB_D(ja,jz)).le.vB_O_nu1(ja,jz)) then !13apr21
!!*         DEF(ja,jtheta,jz,jnu)=zero
!!*         AA(ja,jtheta,jz,jnu,0)=delta*Aj(ja)
!!*         TT(ja,jtheta,jz,jnu,0)=Aj(ja)
!!*    else
!!*         if(vB_ND(ja,jz).ge.vB_D(ja,jz)) then
!!*             DEF(ja,jtheta,jz,jnu)=zero
!!*         else
!!*             DEF(ja,jtheta,jz,jnu)=one
!!*         end if
!!*         AA(ja,jtheta,jz,jnu,0)=Aj(locaprB_ND(ja,jz,jnu))
!!*         TT(ja,jtheta,jz,jnu,0)=tauB_ND(ja,jz,jnu)
!!*    end if
!!*   end do
!!*  end do
!!* end if
!!*
!!*     open(297, file='DEF_barg_nu1_fig.dat')
!!*     write(297,'(3a3,a5,x,4a8,2a12)') 'jnu', 'jth','jz','ja', 'a',   &
!!*                &   'DEF ', 'DEFold ', 'diffD', 'vB_ND', 'vB_D'
!!*       do jz = 1, nz
!!*        do ja=1,nA
!!*         write(297,'(3i3,i5,x,4f8.4,2f12.8)') jnu,jtheta,jz,ja,    &
!!*                &   Aj(ja), &
!!*                &   DEF(ja,jtheta,jz,jnu), DEFold(ja,jz), &
!!*                &   abs(DEF(ja,jtheta,jz,jnu)- DEFold(ja,jz)), &
!!*                &   vB_ND(ja,jz), vB_D(ja,jz)
!!*        end do
!!*       end do
!!*     close(297)
!!*
!!*     deallocate(DEFold)
!!*
!!*  end subroutine barg_nu1
!!*
!!* ! ***********************************************************
!!* !02jun21
!!*  subroutine barg_nu2
!!* !
!!* ! Local: jtheta jnu ja jz
!!* !        DEFold
!!* !
!!* ! Globals:  Aj
!!* !           wB_ND wB_D locaprB_ND tauB_ND
!!* !           DEF TT AA
!!* !
!!*     implicit none
!!*     integer :: jtheta, jnu, ja, jz
!!*     real(prec),  allocatable ::  DEFold(:,:)
!!*     real(prec) :: vaux
!!*
!!*     real(prec) :: u_aux, termD, termND !02jun21
!!*
!!*     allocate(DEFold(1:nA,1:nz))
!!*
!!*     jtheta=1
!!*     jnu=2
!!*     DEFold(1:nA,1:nz)=DEF(1:nA,jtheta,1:nz,jnu)
!!*
!!* !13apr21: comment in if flag does not apply
!!* if((barg_option.eq.0).or.(barg_option.eq.2)) then
!!*     do ja=1, nA
!!*      do jz=1, nz
!!* !02jun21    if(wB_ND(ja,jz).ge.wB_D(ja,jz)) then
!!* !02jun21     DEF(ja,jtheta,jz,jnu)=zero
!!* !02jun21    else
!!* !02jun21     DEF(ja,jtheta,jz,jnu)=one
!!* !02jun21    end if
!!*      u_aux=sigEV*log(scaleuEV)-max(wB_D(ja,jz),wB_ND(ja,jz)) !02jun21
!!*      termD=exp((wB_D(ja,jz)+u_aux)/sigEV)
!!*      termND=exp((wB_ND(ja,jz)+u_aux)/sigEV)
!!*      DEF(ja,jtheta,jz,jnu)=termD/(termD+termND)             !02jun21
!!*
!!*     AA(ja,jtheta,jz,jnu,0)=Aj(locaprB_ND(ja,jz,jnu))
!!*     !!AA(ja,jtheta,jz,jnu,0)=zero         !14apr21  TEMP arrang
!!*     !!DEF(ja,jtheta,jz,jnu)=zero !one-lambda    !14apr21  TEMP arrang
!!*      end do
!!*     end do
!!*     TT(:,jtheta,:,jnu,0)=tauB_ND(:,:,jnu)
!!*     !!TT(:,jtheta,:,jnu,0)=zero           !14apr21  TEMP arrang
!!* end if
!!*
!!* !13apr21
!!* if(barg_option.eq.1) then
!!*  do ja=1, nA
!!*   do jz=1, nz
!!*     if(wB_ND(ja,jz).ge.wB_D(ja,jz)) then
!!*      vaux=vB_ND_nu2(ja,jz)
!!*     else
!!*      vaux=vB_D_nu2(ja,jz)
!!*     end if
!!*    if(vaux.le.vB_O_nu2(ja,jz)) then
!!*         DEF(ja,jtheta,jz,jnu)=zero
!!*         AA(ja,jtheta,jz,jnu,0)=delta*Aj(ja)
!!*         TT(ja,jtheta,jz,jnu,0)=Aj(ja)
!!*    else
!!*         if(wB_ND(ja,jz).ge.wB_D(ja,jz)) then
!!*          DEF(ja,jtheta,jz,jnu)=zero
!!*         else
!!*          DEF(ja,jtheta,jz,jnu)=one
!!*         end if
!!*         AA(ja,jtheta,jz,jnu,0)=Aj(locaprB_ND(ja,jz,jnu))
!!*         TT(ja,jtheta,jz,jnu,0)=tauB_ND(ja,jz,jnu)
!!*    end if
!!*   end do
!!*  end do
!!* end if
!!*
!!*     open(297, file='DEF_barg_nu2_fig.dat')
!!*     write(297,'(3a3,a5,x,4a8,2a12)') 'jnu', 'jth','jz','ja', 'a',   &
!!*                &   'DEF ', 'DEFold ', 'diffD', 'wB_ND', 'wB_D '
!!*       do jz = 1, nz
!!*        do ja=1,nA
!!*         write(297,'(3i3,i5,x,4f8.4,2f12.8)') jnu,jtheta,jz,ja,    &
!!*                &   Aj(ja), &
!!*                &   DEF(ja,jtheta,jz,jnu), DEFold(ja,jz), &
!!*                &   abs(DEF(ja,jtheta,jz,jnu)- DEFold(ja,jz)), &
!!*                &    wB_ND(ja,jz), wB_D(ja,jz)
!!*        end do
!!*       end do
!!*     close(297)
!!*
!!*     deallocate(DEFold)
!!*
!!*  end subroutine barg_nu2
!!*
!!* !*************************************************************
!!* !02jun21
!!*  subroutine barg_agentval
!!* ! Locals: jnu jz jtheta ja
!!* !         thetapr aapr cons d01 prob
!!* !         vv_aux
!!* !
!!* ! Globals:  nnu nz  nA zj piz beta
!!* !           TT AA
!!* !           vv (OUT)
!!* ! Dependencies: use interp
!!* !               function utt psi vexp_theta1_c
!!* !
!!*  use interp
!!*  implicit none
!!*  integer :: jnu,jz,jtheta,ja,jthetapr, d01
!!*  real(prec) :: aapr, cons, prob
!!*  real(prec),  allocatable ::  vv_aux(:,:,:)
!!*  allocate ( vv_aux(1:nA,1:nz,1:nnu) )
!!*
!!*  jtheta=1
!!*  jnu=2 !02jun21
!!*   do jz = 1, nz
!!*    do ja=1,nA
!!*       !case: no recovery; excluded forever
!!*       !!vv(ja,jtheta,jz,jnu)=utt(zj(jz)*psi(jtheta,jz))+beta*sum(piz(jz,:)*vv(ja,jtheta,:,jnu))
!!*       !d01=1
!!*       !cons=zj(jz)*psi(jtheta,jz)-TT(ja,jtheta,jz,jnu,d01)
!!*       !aapr=AA(ja,jtheta,jz,jnu,d01)
!!*       !jthetapr=1
!!*       !vv(ja,jtheta,jz,jnu)=utt(cons)+beta*vexp_theta1_c(aapr)
!!*
!!*       vv_aux(ja,jz,jnu)=zero
!!*       do d01=0,1
!!*        jthetapr=d01
!!*        cons=zj(jz)*psi(jtheta,jz)-TT(ja,jtheta,jz,jnu,d01)
!!*        aapr=AA(ja,jtheta,jz,jnu,d01)
!!*        if(d01.eq.0) prob=one-DEF(ja,jtheta,jz,jnu)
!!*        if(d01.eq.1) prob=DEF(ja,jtheta,jz,jnu)
!!*        vv_aux(ja,jz,jnu)=vv_aux(ja,jz,jnu)     &
!!*         & + prob*(utt(cons)+beta*vexp_theta1_c(aapr))
!!*       end do
!!*
!!*       !case: exog recovery kappa; instant return
!!*       !aapr=kappa*Aj(ja)
!!*       !jthetapr=0
!!*       !vv(ja,jtheta,jz,jnu)=utt(zj(jz)*psi(jtheta,jz))+beta*vexp_theta1_c(aapr)
!!*    end do
!!*   end do
!!*
!!*     vv_temp(:,jtheta,:,jnu)=vv_aux(:,:,jnu) !02jun21
!!*
!!*  deallocate(vv_aux)
!!*
!!*  contains
!!* !-----------------------------------------------------------------------
!!*   function vexp_theta1_c(apr)
!!* ! Globals: nnu nz
!!* !
!!* ! Globals (host barg_agentval): jthetapr jz jnu
!!* !
!!* ! Locals: jnupr jzpr
!!* !         vinterp apr
!!* !         vexp_theta1_c (OUT)
!!* !
!!* ! Dependencies: function vvinterp
!!* !
!!*     implicit none
!!*     real(prec) :: apr, vexp_theta1_c, vinterp
!!*     integer :: jnupr, jzpr
!!*
!!*       vexp_theta1_c=zero
!!*       do jnupr=1,nnu
!!*        do jzpr=1, nz
!!*        vinterp=vvinterp(apr,jthetapr,jzpr,jnupr)
!!*        vexp_theta1_c=vexp_theta1_c+pinu(jnu,jnupr)*piz(jz,jzpr)*vinterp
!!*        end do
!!*       end do
!!*
!!*   end function vexp_theta1_c
!!* !-----------------------------------------------------------------------
!!*   function vvinterp(aapr,jthetapr,jzpr,jnupr)
!!*   implicit none
!!* ! Globals: Aj
!!* !          vv
!!* !
!!* ! Globals (host agentND_opt): vvinterp (OUT)
!!* !
!!* ! Local: aapr jthetapr jzpr jnupr
!!* !        apr
!!* !        japrlow, japrup
!!* !        vtemp_ND vtemp_D
!!* !
!!* ! Dependencies: lip
!!* !
!!*   real(prec), intent(in) :: aapr
!!*   integer, intent(in)    :: jthetapr, jzpr, jnupr
!!*   real(prec) :: apr
!!*   integer    :: japrlow, japrup
!!*   real(prec) :: vtemp_ND, vtemp_D
!!*   real(prec) :: vvinterp
!!*
!!*   apr=max(Aj(1), aapr)
!!*   apr=min(Aj(na), apr)
!!*   japrlow=count(Aj.le.apr)
!!*   japrup=min(japrlow+1,nA)
!!*
!!*   if(interp_theta1v.eq.1) &
!!*     & vvinterp=lip(Aj(:),vv(:,jthetapr,jzpr,jnupr),apr)
!!*
!!*   end function vvinterp
!!* !-----------------------------------------------------------------------
!!*  end subroutine barg_agentval



!*************************************************************
! [7.] LENDER'S VALUE
!*************************************************************
 subroutine lender_iter

 use interp
 implicit none
 integer :: jnu, jz, jtheta, ja, jthetapr
 real(prec),  allocatable ::  HH_temp(:,:,:,:), Hold(:,:,:,:)
 real(prec) :: transf0, aapr0, transf1, aapr1
 real(prec),  allocatable ::  H2d(:,:,:,:)
 real(prec) :: natspli

 integer :: jthetapr0, jthetapr1
 real(prec) :: Hexp0, Hexp1
 real(prec), allocatable :: Hexp_theta0_2d(:,:,:,:), Hexp_theta0_arr(:,:,:,:)

 allocate ( HH_temp(1:nA,0:ntheta,1:nz,1:nnu))
 allocate ( Hold(1:nA,0:ntheta,1:nz,1:nnu))
 allocate ( H2d(1:nA,0:ntheta,1:nz,1:nnu))
 allocate (Hexp_theta0_2d(1:nA,0:ntheta,1:nz,1:nnu), Hexp_theta0_arr(1:nA,0:ntheta,1:nz,1:nnu) )

 Hold(:,:,:,:)=HH(:,:,:,:)

 ! .. Build spline state by state - 2nd deriv H2d ..
    if(interp_H.eq.2) then
    natspli=1.0E30_prec+small
    do jtheta=0, ntheta
     do jnu= 1, nnu
      do jz=  1, nz
      call spline(Aj(1:nA),HH(1:nA,jtheta,jz,jnu),natspli,natspli,H2d(1:nA,jtheta,jz,jnu))
      end do
     end do
    end do
    end if

 ! .. Create array for expected value for theta=0: Hexp_theta0_arr(japr,jthetapr,jz)
    if(interp_Hexp0.gt.0) call Hexp_theta0_arr_defi
 ! .. Build spline over expected value - 2nd deriv Hexp_theta0_2d ..
    if(interp_Hexp0.eq.2) then
    natspli=1.0E30_prec+small
    do jthetapr=0, ntheta
     do jnu= 1, nnu
      do jz=  1, nz
        call spline(Aj(1:nA),Hexp_theta0_arr(1:nA,jthetapr,jz,jnu), &
                &   natspli,natspli,Hexp_theta0_2d(1:nA,jthetapr,jz,jnu))
      end do
     end do
    end do
    end if

 do jnu=1, nnu
  do jz=1, nz
    do ja= 1, nA

    !------------
    jtheta=0
    !------------
    if(interp_Hexp0.gt.0) then
    jthetapr0=0
    aapr0=AA(ja,jtheta,jz,jnu,0)
      if(interp_Hexp0.eq.2) &
       & Hexp0=splint(Aj(1:nA), &
       &        Hexp_theta0_arr(1:nA,jthetapr0,jz,jnu), &
       &        Hexp_theta0_2d(1:nA,jthetapr0,jz,jnu),   &
       &        aapr0)
      if(interp_Hexp0.eq.1) &
       &        Hexp0=lip(Aj(:),Hexp_theta0_arr(1:nA,jthetapr0,jz,jnu),aapr0)

    jthetapr1=1
    aapr1=AA(ja,jtheta,jz,jnu,1)
      if(interp_Hexp0.eq.2) &
       &        Hexp1=splint(Aj(1:nA), &
       &        Hexp_theta0_arr(1:nA,jthetapr1,jz,jnu), &
       &        Hexp_theta0_2d(1:nA,jthetapr1,jz,jnu),   &
       &        aapr1)
      if(interp_Hexp0.eq.1) &
       &        Hexp1=lip(Aj(:),Hexp_theta0_arr(1:nA,jthetapr1,jz,jnu),aapr1)

    HH_temp(ja,jtheta,jz,jnu)=(one-DEF(ja,jtheta,jz,jnu))  &
            &   +q0*(delta*(one-DEF(ja,jtheta,jz,jnu))*Hexp0 &
            &   + DEF(ja,jtheta,jz,jnu)*Hexp1         &
            &       )
    end if

    if(interp_Hexp0.eq.0) then
      HH_temp(ja,jtheta,jz,jnu)=(one-DEF(ja,jtheta,jz,jnu))  &
            &   +q0*(delta*(one-DEF(ja,jtheta,jz,jnu))*Hexp(AA(ja,jtheta,jz,jnu,0),0) &
            &   + DEF(ja,jtheta,jz,jnu)*Hexp(AA(ja,jtheta,jz,jnu,1),1)         &
            &       )
    end if

    !------------
    jtheta=1
    !------------
      transf0=TT(ja,jtheta,jz,jnu,0)
      aapr0=AA(ja,jtheta,jz,jnu,0)
      transf1=TT(ja,jtheta,jz,jnu,1)
      aapr1=AA(ja,jtheta,jz,jnu,1)
      HH_temp(ja,jtheta,jz,jnu)= &
        & (one-DEF(ja,jtheta,jz,jnu))* &
        & (transf0/max(Aj(ja),Aj(nAzero+1)) &
        & + q0*(aapr0/max(Aj(ja),Aj(nAzero+1)))*Hexp(aapr0,0)) &
        & +DEF(ja,jtheta,jz,jnu)* &
        & (transf1/max(Aj(ja),Aj(nAzero+1)) &
        & + q0*(aapr1/max(Aj(ja),Aj(nAzero+1)))*Hexp(aapr1,1))

if((jnu.eq.1).and.(jz.eq.1).and.(ja.eq.2)) &
 & write(*,*) 'def', DEF(ja,jtheta,jz,jnu), 'tau0', transf0, &
 & 'apr0', aapr0, 'apr1', aapr1, 'Hexp', Hexp(aapr0,0)

    end do
  end do
 end do

 errmaxH=maxval(abs(HH_temp(nAzero+1:nA,0:ntheta,1:nz,1:nnu)-Hold(nAzero+1:nA,0:ntheta,1:nz,1:nnu)))

 HH(:,:,:,:)=HH_temp(:,:,:,:)

open(297, file='H_thet0_fig.dat')
write(297,'(3a3,a5,x,4a8)') 'jnu', 'jth','jz','ja',    &
           &   'a', 'H ', 'Hold ', 'diffH'
do jnu=1, nnu
 do jtheta=0, 0
  do jz = 1, nz
   do ja=1,nA
    write(297,'(3i3,i5,x,f8.3,f8.3,f8.3,f8.3)') jnu,jtheta,jz,ja,    &
           &   Aj(ja), &
           &   HH(ja,jtheta,jz,jnu), Hold(ja,jtheta,jz,jnu), &
           &   abs(HH(ja,jtheta,jz,jnu)- Hold(ja,jtheta,jz,jnu))
   end do
  end do
 end do
end do
close(297)

open(297, file='H_thet1_fig.dat')
write(297,'(3a3,a5,x,4a8)') 'jnu', 'jth','jz','ja', 'a',   &
           &   'H ', 'Hold ', 'diffH'
do jnu=1, nnu
 do jtheta=1, 1
  do jz = 1, nz
   do ja=1,nA
    write(297,'(3i3,x,i5,f8.3,f8.3,f8.3,f8.3)') jnu,jtheta,jz,ja,    &
           &   Aj(ja), &
           &   HH(ja,jtheta,jz,jnu), Hold(ja,jtheta,jz,jnu), &
           &   abs(HH(ja,jtheta,jz,jnu)- Hold(ja,jtheta,jz,jnu))
   end do
  end do
 end do
end do
close(297)

!23apr21
 HH(:,:,:,:)=max(HH(:,:,:,:),zero)

 HH(:,:,:,:)=speed_adjh*HH(:,:,:,:)+(one-speed_adjh)*Hold(:,:,:,:)

 deallocate(HH_temp,Hold)
 deallocate ( H2d)
 deallocate(Hexp_theta0_2d,Hexp_theta0_arr)


 contains

!-----------------------------------------------------------
 subroutine Hexp_theta0_arr_defi
 implicit none
 integer :: japr, jthetapr, jz, jnu, jnupr
 real(prec) :: Hexp
 do japr= 1, nA
  do jthetapr= 0, ntheta
   do jz= 1, nz
    do jnu= 1, nnu
        Hexp=zero
        do jnupr=1, nnu
         Hexp=Hexp &
            & +pinu(jnu,jnupr)*sum(piz(jz,1:nz)*HH(japr,jthetapr,1:nz,jnupr))
        end do
        Hexp_theta0_arr(japr,jthetapr,jz,jnu)=Hexp
    end do
   end do
  end do
 end do
 end subroutine Hexp_theta0_arr_defi
!-----------------------------------------------------------
 function Hexp(aapr,jthetapr)
! Local: HHpr
!        jthetapr aapr jzpr jnupr
!        Hexp (OUT)
! Global (host): jz jnu
!
! Global: HH
!         nz nnu pinu piz
! Dependencies: function lip splint
!
    implicit none
    real(prec) :: aapr, HHpr
    integer :: jthetapr, jzpr, jnupr
    real(prec) :: Hexp

    Hexp=zero
    do jzpr=1, nz
     do jnupr=1, nnu
      if(interp_H.eq.1) &
       & HHpr=lip(Aj(:),HH(:,jthetapr,jzpr,jnupr),aapr)
      if(interp_H.eq.2) &
       &  HHpr=splint(Aj(1:nA), &
       &        HH(1:nA,jthetapr,jzpr,jnupr),H2d(1:nA,jthetapr,jzpr,jnupr),aapr)
         Hexp=Hexp+pinu(jnu,jnupr)*piz(jz,jzpr)*HHpr
     end do
    end do
 end function Hexp
!-----------------------------------------------------------

 end subroutine lender_iter



!*************************************************************
 subroutine lender_iter_old
! Locals:  jnu jz jtheta ja
!          HH_temp Hold
!          transf0 aapr0 transf1 aapr1
!          natspli
! Globals:  nnu nz ntheta small nA Aj
!           DEF TT AA
!           delta q0 speed_adjh
!           HH (IN/OUT)
!           errmaxH (OUT)
! Dependencies: use interp
!               Hexp()
!               call spline

 use interp
 implicit none
 integer :: jnu, jz, jtheta, ja
 real(prec),  allocatable ::  HH_temp(:,:,:,:), Hold(:,:,:,:)
 real(prec) :: transf0, aapr0, transf1, aapr1
 real(prec),  allocatable ::  H2d(:,:,:,:)
 real(prec) :: natspli

 allocate ( HH_temp(1:nA,0:ntheta,1:nz,1:nnu))
 allocate ( Hold(1:nA,0:ntheta,1:nz,1:nnu))
 allocate ( H2d(1:nA,0:ntheta,1:nz,1:nnu))

 Hold(:,:,:,:)=HH(:,:,:,:)


    if(interp_H.eq.2) then
    natspli=1.0E30_prec+small
    do jtheta=0, ntheta
     do jnu= 1, nnu
      do jz=  1, nz
      call spline(Aj(1:nA),HH(1:nA,jtheta,jz,jnu),natspli,natspli,H2d(1:nA,jtheta,jz,jnu))
      end do
     end do
    end do
    end if

 do jnu=1, nnu
  do jz=1, nz
    do ja= 1, nA

    jtheta=0
      HH_temp(ja,jtheta,jz,jnu)=(one-DEF(ja,jtheta,jz,jnu))  &
!            &   +q0*(delta*(one-DEF(ja,jtheta,jz,jnu))    &
!            &                   +DEF(ja,jtheta,jz,jnu)) &
!            &             * ( &
            &   +q0*(delta*(one-DEF(ja,jtheta,jz,jnu))*Hexp(AA(ja,jtheta,jz,jnu,0),0) &
            &   + DEF(ja,jtheta,jz,jnu)*Hexp(AA(ja,jtheta,jz,jnu,1),1)         &
            &       )
    jtheta=1
      transf0=TT(ja,jtheta,jz,jnu,0)
      aapr0=AA(ja,jtheta,jz,jnu,0)
      transf1=TT(ja,jtheta,jz,jnu,1)
      aapr1=AA(ja,jtheta,jz,jnu,1)

!      transf0=zero
!      aapr0=zero
!      transf1=zero
!      aapr1=zero

!      HH_temp(ja,jtheta,jz,jnu)= zero
      HH_temp(ja,jtheta,jz,jnu)= &
        & (one-DEF(ja,jtheta,jz,jnu))* &
        & (transf0/max(Aj(ja),Aj(nAzero+1)) &
        & + q0*(aapr0/max(Aj(ja),Aj(nAzero+1)))*Hexp(aapr0,0)) &
        & +DEF(ja,jtheta,jz,jnu)* &
        & (transf1/max(Aj(ja),Aj(nAzero+1)) &
        & + q0*(aapr1/max(Aj(ja),Aj(nAzero+1)))*Hexp(aapr1,1))

if((jnu.eq.1).and.(jz.eq.1).and.(ja.eq.2)) &
 & write(*,*) 'def', DEF(ja,jtheta,jz,jnu), 'tau0', transf0, &
 & 'apr0', aapr0, 'apr1', aapr1, 'Hexp', Hexp(aapr0,0)


!***new
!! HH_temp(ja,jtheta,jz,jnu)=min(HH_temp(ja,jtheta,jz,jnu),one/(one-q0*delta))


!      HH_temp(ja,jtheta,jz,jnu)= zero !12may21

!      jtheta=1
!      !case: no recovery; excluded forever
!      !HH_temp(ja,jtheta,jz,jnu)=zero
!      ! for given TT AA etc ...
!      transf0=TT(ja,jtheta,jz,jnu,0)
!      aapr0=AA(ja,jtheta,jz,jnu,0)
!      transf1=TT(ja,jtheta,jz,jnu,1)
!      aapr1=AA(ja,jtheta,jz,jnu,1)
!      HH_temp(ja,jtheta,jz,jnu)= &
!        & (one-DEF(ja,jtheta,jz,jnu))* &
!        & (transf0/max(Aj(ja),small) &
!        & + q0*(aapr0/max(Aj(ja),small))*Hexp(aapr0,0)) &
!        & DEF(ja,jtheta,jz,jnu)* &
!        & (transf1/max(Aj(ja),small) &
!        & + q0*(aapr1/max(Aj(ja),small))*Hexp(aapr1,1))

      !case: exog recovery kappa; instant return
      !HH_temp(ja,jtheta,jz,jnu)=kappa  &
      !      &   +q0*delta*kappa    &
      !      &             * Hexp(kappa*Aj(ja),0)
!      HH_temp(ja,jtheta,jz,jnu)= TT(ja,jtheta,jz,jnu)/max(Aj(ja),small) &
!        & + q0*(TT(ja,jtheta,jz,jnu)/max(Aj(ja),small)) &
!        &       *Hexp()
    end do
  end do
 end do

 errmaxH=maxval(abs(HH_temp(nAzero+1:nA,0:ntheta,1:nz,1:nnu)-Hold(nAzero+1:nA,0:ntheta,1:nz,1:nnu)))


 HH(:,:,:,:)=HH_temp(:,:,:,:)


open(297, file='H_thet0_fig.dat')
write(297,'(3a3,a5,x,4a8)') 'jnu', 'jth','jz','ja',    &
           &   'a', 'H ', 'Hold ', 'diffH'
do jnu=1, nnu
 do jtheta=0, 0
  do jz = 1, nz
   do ja=1,nA
    write(297,'(3i3,i5,x,f8.3,f8.3,f8.3,f8.3)') jnu,jtheta,jz,ja,    &
           &   Aj(ja), &
           &   HH(ja,jtheta,jz,jnu), Hold(ja,jtheta,jz,jnu), &
           &   abs(HH(ja,jtheta,jz,jnu)- Hold(ja,jtheta,jz,jnu))
   end do
  end do
 end do
end do
close(297)

open(297, file='H_thet1_fig.dat')
write(297,'(3a3,a5,x,4a8)') 'jnu', 'jth','jz','ja', 'a',   &
           &   'H ', 'Hold ', 'diffH'
do jnu=1, nnu
 do jtheta=1, 1
  do jz = 1, nz
   do ja=1,nA
    write(297,'(3i3,x,i5,f8.3,f8.3,f8.3,f8.3)') jnu,jtheta,jz,ja,    &
           &   Aj(ja), &
           &   HH(ja,jtheta,jz,jnu), Hold(ja,jtheta,jz,jnu), &
           &   abs(HH(ja,jtheta,jz,jnu)- Hold(ja,jtheta,jz,jnu))
   end do
  end do
 end do
end do
close(297)

!23apr21
 HH(:,:,:,:)=max(HH(:,:,:,:),zero)

 HH(:,:,:,:)=speed_adjh*HH(:,:,:,:)+(one-speed_adjh)*Hold(:,:,:,:)

 deallocate(HH_temp,Hold)
 deallocate ( H2d)

 contains
!-----------------------------------------------------------
 function Hexp(aapr,jthetapr)
! Local: HHpr
!        jthetapr aapr jzpr jnupr
!        Hexp (OUT)
! Global (host): jz jnu
!
! Global: HH
!         nz nnu pinu piz
! Dependencies: function lip splint
!
    implicit none
    real(prec) :: aapr, HHpr
    integer :: jthetapr, jzpr, jnupr
    real(prec) :: Hexp

    Hexp=zero
    do jzpr=1, nz
     do jnupr=1, nnu
      if(interp_H.eq.1) &
       & HHpr=lip(Aj(:),HH(:,jthetapr,jzpr,jnupr),aapr)
!!***      if(interp_H.eq.2) then
!!***       if(jthetapr.eq.0) &
!!***       &  HHpr=splint(Aj(1:nA), &
!!***       &        HH(1:nA,jthetapr,jzpr,jnupr),H2d(1:nA,jthetapr,jzpr,jnupr),aapr)
!!***       if(jthetapr.eq.1) &
!!***       & HHpr=lip(Aj(:),HH(:,jthetapr,jzpr,jnupr),aapr)
!!***     end if
      if(interp_H.eq.2) &
       &  HHpr=splint(Aj(1:nA), &
       &        HH(1:nA,jthetapr,jzpr,jnupr),H2d(1:nA,jthetapr,jzpr,jnupr),aapr)
         Hexp=Hexp+pinu(jnu,jnupr)*piz(jz,jzpr)*HHpr
!if(jnupr.eq.1) Hexp=Hexp+piz(jz,jzpr)*HHpr
!if(jnupr.eq.2) Hexp=Hexp
     end do
    end do
 end function Hexp
!-----------------------------------------------------------

!!-----------------------------------------------------------
! function Hexp(jthetapr)
!! Local: aapr HHpr
!!        jthetapr jzpr jnupr
!!        Hexp (OUT)
!! Global (host): ja jtheta jz jnu
!!
!! Global: AAND AAD HH
!!         nz nnu pinu piz
!! Dependencies: function lip
!!
!    implicit none
!    real(prec) :: aapr, HHpr
!    integer :: jthetapr, jzpr, jnupr
!    real(prec) :: Hexp
!
!    if(jthetapr.eq.0) then
!     aapr=AAND(ja,jz,jnu)
!    else if(jthetapr.eq.1) then
!     aapr=AAD(ja,jz,jnu)
!    end if
!
!    Hexp=zero
!    do jzpr=1, nz
!     do jnupr=1, nnu
!        HHpr=lip(Aj(:),HH(:,jthetapr,jzpr,jnupr),aapr)
!        Hexp=Hexp+pinu(jnu,jnupr)*piz(jz,jzpr)*HHpr
!     end do
!    end do
! end function Hexp
!!-----------------------------------------------------------

!!-----------------------------------------------------------
! function Hexp()
!! Local: aapr HHpr
!!        jthetapr jzpr jnupr
!!        Hexp (OUT)
!! Global (host): ja jtheta jz jnu
!!
!! Global: AA D01 HH
!!         nz nnu pinu piz
!! Dependencies: function lip
!!
!    implicit none
!    real(prec) :: aapr, HHpr
!    integer :: jthetapr, jzpr, jnupr
!    real(prec) :: Hexp
!
!    aapr=AA(ja,jtheta,jz,jnu)
!    jthetapr=D01(ja,jtheta,jz,jnu)
!    Hexp=zero
!    do jzpr=1, nz
!     do jnupr=1, nnu
!        HHpr=lip(Aj(:),HH(:,jthetapr,jzpr,jnupr),aapr)
!        Hexp=Hexp+pinu(jnu,jnupr)*piz(jz,jzpr)*HHpr
!     end do
!    end do
! end function Hexp
!!-----------------------------------------------------------
 end subroutine lender_iter_old

!*!*************************************************************
!* subroutine lender_iter
!*! Locals:  jnu jz jtheta ja
!*!          HH_temp Hold
!*! Globals:  nnu nz ntheta small nA Aj
!*!           DEF TT AA
!*!           delta q0
!*!           HH (IN/OUT)
!*!           errmaxH0 (OUT)
!*! Dependencies: use interp
!*!               Hexp()
!*!
!*
!* use interp
!* implicit none
!* integer :: jnu, jz, jtheta, ja
!* real(prec),  allocatable ::  HH_temp(:,:,:,:), Hold(:,:,:,:)
!*
!* allocate ( HH_temp(1:nA,0:ntheta,1:nz,1:nnu))
!* allocate ( Hold(1:nA,0:ntheta,1:nz,1:nnu))
!*
!* Hold(:,0,:,:)=HH(:,0,:,:)
!*
!* jtheta=0
!* do jnu=1, nnu
!*  do jz=1, nz
!*    do ja= 1, nA
!*
!*
!*      HH_temp(ja,jtheta,jz,jnu)=(one-DEF(ja,jtheta,jz,jnu))  &
!*            &   +q0*(delta*(one-DEF(ja,jtheta,jz,jnu))    &
!*            &                   +DEF(ja,jtheta,jz,jnu)) &
!*            &             * ( &
!*            &   (one-DEF(ja,jtheta,jz,jnu))*Hexp(AA(ja,jtheta,jz,jnu,0),0) &
!*            &   + DEF(ja,jtheta,jz,jnu)*Hexp(AA(ja,jtheta,jz,jnu,1),1)         &
!*            &       )
!*
!*!      jtheta=1
!*!      !case: no recovery; excluded forever
!*!      !HH_temp(ja,jtheta,jz,jnu)=zero
!*!      ! for given TT AA etc ...
!*!      transf0=TT(ja,jtheta,jz,jnu,0)
!*!      aapr0=AA(ja,jtheta,jz,jnu,0)
!*!      transf1=TT(ja,jtheta,jz,jnu,1)
!*!      aapr1=AA(ja,jtheta,jz,jnu,1)
!*!      HH_temp(ja,jtheta,jz,jnu)= &
!*!        & (one-DEF(ja,jtheta,jz,jnu))* &
!*!        & (transf0/max(Aj(ja),small) &
!*!        & + q0*(aapr0/max(Aj(ja),small))*Hexp(aapr0,0)) &
!*!        & DEF(ja,jtheta,jz,jnu)* &
!*!        & (transf1/max(Aj(ja),small) &
!*!        & + q0*(aapr1/max(Aj(ja),small))*Hexp(aapr1,1))
!*
!*      !case: exog recovery kappa; instant return
!*      !HH_temp(ja,jtheta,jz,jnu)=kappa  &
!*      !      &   +q0*delta*kappa    &
!*      !      &             * Hexp(kappa*Aj(ja),0)
!*!      HH_temp(ja,jtheta,jz,jnu)= TT(ja,jtheta,jz,jnu)/max(Aj(ja),small) &
!*!        & + q0*(TT(ja,jtheta,jz,jnu)/max(Aj(ja),small)) &
!*!        &       *Hexp()
!*    end do
!*  end do
!* end do
!*
!* errmaxH0=maxval(abs(HH_temp(:,jtheta,:,:)-Hold(:,jtheta,:,:)))
!*
!* HH(:,jtheta,:,:)=HH_temp(:,jtheta,:,:)
!*
!*
!*open(297, file='H_thet0_fig.dat') !12feb15
!*write(297,'(4a3,x,3a8)') 'jnu', 'jth','jz','ja',    &
!*           &   'H ', 'Hold ', 'diffH'
!*do jnu=1, nnu
!* do jtheta=0, 0
!*  do jz = 1, nz
!*   do ja=1,nA
!*    write(297,'(4i3,x,f8.3,f8.3,f8.3,f8.3)') jnu,jtheta,jz,ja,    &
!*           &   HH(ja,jtheta,jz,jnu), Hold(ja,jtheta,jz,jnu), &
!*           &   abs(HH(ja,jtheta,jz,jnu)- Hold(ja,jtheta,jz,jnu))
!*   end do
!*  end do
!* end do
!*end do
!*close(297)
!*
!*
!* deallocate(HH_temp,Hold)
!*
!*
!* contains
!*!-----------------------------------------------------------
!* function Hexp(aapr,jthetapr)
!*! Local: HHpr
!*!        jthetapr aapr jzpr jnupr
!*!        Hexp (OUT)
!*! Global (host): jz jnu
!*!
!*! Global: HH
!*!         nz nnu pinu piz
!*! Dependencies: function lip
!*!
!*    implicit none
!*    real(prec) :: aapr, HHpr
!*    integer :: jthetapr, jzpr, jnupr
!*    real(prec) :: Hexp
!*
!*    Hexp=zero
!*    do jzpr=1, nz
!*     do jnupr=1, nnu
!*        HHpr=lip(Aj(:),HH(:,jthetapr,jzpr,jnupr),aapr)
!*        Hexp=Hexp+pinu(jnu,jnupr)*piz(jz,jzpr)*HHpr
!*     end do
!*    end do
!* end function Hexp
!*!-----------------------------------------------------------
!*
!*!!-----------------------------------------------------------
!*! function Hexp(jthetapr)
!*!! Local: aapr HHpr
!*!!        jthetapr jzpr jnupr
!*!!        Hexp (OUT)
!*!! Global (host): ja jtheta jz jnu
!*!!
!*!! Global: AAND AAD HH
!*!!         nz nnu pinu piz
!*!! Dependencies: function lip
!*!!
!*!    implicit none
!*!    real(prec) :: aapr, HHpr
!*!    integer :: jthetapr, jzpr, jnupr
!*!    real(prec) :: Hexp
!*!
!*!    if(jthetapr.eq.0) then
!*!     aapr=AAND(ja,jz,jnu)
!*!    else if(jthetapr.eq.1) then
!*!     aapr=AAD(ja,jz,jnu)
!*!    end if
!*!
!*!    Hexp=zero
!*!    do jzpr=1, nz
!*!     do jnupr=1, nnu
!*!        HHpr=lip(Aj(:),HH(:,jthetapr,jzpr,jnupr),aapr)
!*!        Hexp=Hexp+pinu(jnu,jnupr)*piz(jz,jzpr)*HHpr
!*!     end do
!*!    end do
!*! end function Hexp
!*!!-----------------------------------------------------------
!*
!*!!-----------------------------------------------------------
!*! function Hexp()
!*!! Local: aapr HHpr
!*!!        jthetapr jzpr jnupr
!*!!        Hexp (OUT)
!*!! Global (host): ja jtheta jz jnu
!*!!
!*!! Global: AA D01 HH
!*!!         nz nnu pinu piz
!*!! Dependencies: function lip
!*!!
!*!    implicit none
!*!    real(prec) :: aapr, HHpr
!*!    integer :: jthetapr, jzpr, jnupr
!*!    real(prec) :: Hexp
!*!
!*!    aapr=AA(ja,jtheta,jz,jnu)
!*!    jthetapr=D01(ja,jtheta,jz,jnu)
!*!    Hexp=zero
!*!    do jzpr=1, nz
!*!     do jnupr=1, nnu
!*!        HHpr=lip(Aj(:),HH(:,jthetapr,jzpr,jnupr),aapr)
!*!        Hexp=Hexp+pinu(jnu,jnupr)*piz(jz,jzpr)*HHpr
!*!     end do
!*!    end do
!*! end function Hexp
!*!!-----------------------------------------------------------
!* end subroutine lender_iter

!*************************************************************
 subroutine lender_theta1_iter
! Locals:  jnu jz jtheta ja
!          HH_temp Hold
!          transf0 aapr0 transf1 aapr1
!          natspli
! Globals:  nnu nz ntheta small nA Aj
!           DEF TT AA
!           delta q0
!           HH (IN/OUT)
!           errmaxH1 (OUT)
! Dependencies: use interp
!               Hexp()
!               call spline

 use interp
 implicit none
 integer :: jnu, jz, jtheta, ja
 real(prec) :: transf0, aapr0, transf1, aapr1
 real(prec),  allocatable ::  HH_temp(:,:,:,:), Hold(:,:,:,:)
 real(prec),  allocatable ::  H2d(:,:,:,:)
 real(prec) :: natspli

 allocate ( HH_temp(1:nA,0:ntheta,1:nz,1:nnu))
 allocate ( Hold(1:nA,0:ntheta,1:nz,1:nnu))
 allocate ( H2d(1:nA,0:ntheta,1:nz,1:nnu))

 Hold(:,1,:,:)=HH(:,1,:,:)

    if(interp_H.eq.2) then
    natspli=1.0E30_prec+small
    do jtheta=0, ntheta
     do jnu= 1, nnu
      do jz=  1, nz
      call spline(Aj(1:nA),HH(1:nA,jtheta,jz,jnu),natspli,natspli,H2d(1:nA,jtheta,jz,jnu))
      end do
     end do
    end do
    end if

 jtheta=1
 do jnu=1, nnu
  do jz=1, nz
    do ja= 1, nA

!      jtheta=0
!      HH_temp(ja,jtheta,jz,jnu)=(one-DEF(ja,jtheta,jz,jnu))  &
!            &   +q0*(delta*(one-DEF(ja,jtheta,jz,jnu))    &
!            &                   +DEF(ja,jtheta,jz,jnu)) &
!            &             * ( &
!            &   (one-DEF(ja,jtheta,jz,jnu))*Hexp(AA(ja,jtheta,jz,jnu,0),0) &
!            &   + DEF(ja,jtheta,jz,jnu)*Hexp(AA(ja,jtheta,jz,jnu,1),1)         &
!            &       )

      !case: no recovery; excluded forever
      !HH_temp(ja,jtheta,jz,jnu)=zero
      ! for given TT AA etc ...
      transf0=TT(ja,jtheta,jz,jnu,0)
      aapr0=AA(ja,jtheta,jz,jnu,0)
      transf1=TT(ja,jtheta,jz,jnu,1)
      aapr1=AA(ja,jtheta,jz,jnu,1)
      HH_temp(ja,jtheta,jz,jnu)= &
        & (one-DEF(ja,jtheta,jz,jnu))* &
        & (transf0/max(Aj(ja),small) &
        & + q0*(aapr0/max(Aj(ja),small))*Hexp(aapr0,0)) &
        & +DEF(ja,jtheta,jz,jnu)* &
        & (transf1/max(Aj(ja),small) &
        & + q0*(aapr1/max(Aj(ja),small))*Hexp(aapr1,1))

      !case: exog recovery kappa; instant return
      !HH_temp(ja,jtheta,jz,jnu)=kappa  &
      !      &   +q0*delta*kappa    &
      !      &             * Hexp(kappa*Aj(ja),0)
!      HH_temp(ja,jtheta,jz,jnu)= TT(ja,jtheta,jz,jnu)/max(Aj(ja),small) &
!        & + q0*(TT(ja,jtheta,jz,jnu)/max(Aj(ja),small)) &
!        &       *Hexp()
    end do
  end do
 end do

 errmaxH1=maxval(abs(HH_temp(:,jtheta,:,:)-Hold(:,jtheta,:,:)))

 HH(:,jtheta,:,:)=HH_temp(:,jtheta,:,:)


open(297, file='H_thet1_fig.dat') !12feb15
write(297,'(4a3,x,3a8)') 'jnu', 'jth','jz','ja',    &
           &   'H ', 'Hold ', 'diffH'
do jnu=1, nnu
 do jtheta=1, 1
  do jz = 1, nz
   do ja=1,nA
    write(297,'(4i3,x,f8.3,f8.3,f8.3,f8.3)') jnu,jtheta,jz,ja,    &
           &   HH(ja,jtheta,jz,jnu), Hold(ja,jtheta,jz,jnu), &
           &   abs(HH(ja,jtheta,jz,jnu)- Hold(ja,jtheta,jz,jnu))
   end do
  end do
 end do
end do
close(297)


 deallocate(HH_temp,Hold)
 deallocate (H2d)

 contains
!-----------------------------------------------------------
 function Hexp(aapr,jthetapr)
! Local: HHpr
!        jthetapr aapr jzpr jnupr
!        Hexp (OUT)
! Global (host): jz jnu
!
! Global: HH
!         nz nnu pinu piz
! Dependencies: function lip
!
    implicit none
    real(prec) :: aapr, HHpr
    integer :: jthetapr, jzpr, jnupr
    real(prec) :: Hexp

    Hexp=zero
    do jzpr=1, nz
     do jnupr=1, nnu
      if(interp_H.eq.1) &
       & HHpr=lip(Aj(:),HH(:,jthetapr,jzpr,jnupr),aapr)
      if(interp_H.eq.2) &
       &  HHpr=splint(Aj(1:nA), &
       &        HH(1:nA,jthetapr,jzpr,jnupr),H2d(1:nA,jthetapr,jzpr,jnupr),aapr)
         Hexp=Hexp+pinu(jnu,jnupr)*piz(jz,jzpr)*HHpr
     end do
    end do
 end function Hexp
!-----------------------------------------------------------
 end subroutine lender_theta1_iter

!*************************************************************
! [8.] UPDATE PRICES
!*************************************************************
 subroutine updques
 ! Globals: HH
 !          qqtil errmaxq errq (OUT)
 !          q0
 !          piz pinu nnu nz ntheta nA nAzero
 !          speed_adjq, defout, qtol, writeq
 ! Local: qqtilold
 !       jnu jz jthetapr japr jnupr jzpr
 !       parsum
 ! Dependencies: call write_q

 use interp
 implicit none
 real(prec), dimension(:,:,:,:), allocatable ::  qqtilold
 real(prec), dimension(:,:,:,:), allocatable ::  qqtil_temp
 integer :: jnu, jz, jthetapr, japr, jnupr, jzpr
 real(prec) :: parsum

! Smoothing:    !07jul21
    integer :: factor_reduc, nA_reduc
    real(prec) :: natspli
    real(prec), dimension(:,:,:,:), allocatable ::  qqtil_reduc, qqtil_reduc_2d
    real(prec), dimension(:), allocatable :: Aj_reduc

 allocate (  qqtilold(nAzero:nA,0:ntheta,1:nz,1:nnu) )
 allocate (qqtil_temp(nAzero:nA,0:ntheta,1:nz,1:nnu) )

 qqtilold=qqtil
 !errmaxq=zero


  do jnu= 1, nnu
   do jz= 1, nz
    do jthetapr= 0, ntheta
     do japr= nAzero, nA
         parsum=zero
         do jzpr=1, nz
          do jnupr=1, nnu
           parsum= parsum + &
              & piz(jz,jzpr)*pinu(jnu,jnupr)*HH(japr,jthetapr,jzpr,jnupr)
          end do
         end do
         qqtil_temp(japr,jthetapr,jz,jnu)=q0*parsum
         qqtil(japr,jthetapr,jz,jnu)= speed_adjq*qqtil_temp(japr,jthetapr,jz,jnu) &
                  & +(one-speed_adjq)*qqtilold(japr,jthetapr,jz,jnu)
     end do
    end do
   end do
  end do

! /////////////////////////// SMOOTHING FOR theta=0
!07jul21

!+++! reduced grid
!+++    factor_reduc=2 !4
!+++    !+++ nA_reduc=2+nA/factor_reduc
!+++    nA_reduc=2+(nA-2)/factor_reduc
!+++    allocate (  qqtil_reduc(nAzero:nA_reduc,0:0,1:nz,1:nnu), &
!+++        &       qqtil_reduc_2d(nAzero:nA_reduc,0:0,1:nz,1:nnu) )
!+++    allocate ( Aj_reduc(nAzero:nA_reduc))
!+++
!+++    do japr=nAzero, nA_reduc
!+++     if(japr.le.nAzero+1) then
!+++      Aj_reduc(japr)=Aj(japr)
!+++     else
!+++      !+++ Aj_reduc(japr)=Aj((japr-2)*factor_reduc)
!+++      Aj_reduc(japr)=Aj(2+(japr-2)*factor_reduc)
!+++     end if
!+++     do jnu=1, nnu
!+++      do jz=1, nz
!+++       do jthetapr=0, 0
!+++        if(japr.le.nAzero+1) then
!+++         qqtil_reduc(japr,jthetapr,jz,jnu)=qqtil(japr,jthetapr,jz,jnu)
!+++        else
!+++         !+++qqtil_reduc(japr,jthetapr,jz,jnu)=qqtil((japr-2)*factor_reduc,jthetapr,jz,jnu)
!+++         qqtil_reduc(japr,jthetapr,jz,jnu)=qqtil(2+(japr-2)*factor_reduc,jthetapr,jz,jnu)
!+++        end if
!+++       end do
!+++      end do
!+++     end do
!+++    end do
!+++! spline over reduced function and recover price function
!+++     natspli=1.0E30_prec+small
!+++     do jnu=1, nnu
!+++      do jz=1, nz
!+++       do jthetapr=0, 0
!+++          call spline(Aj_reduc(nAzero+1:nA_reduc),qqtil_reduc(nAzero+1:nA_reduc,jthetapr,jz,jnu), &
!+++            & natspli,natspli,qqtil_reduc_2d(nAzero+1:nA_reduc,jthetapr,jz,jnu))
!+++         do japr=1, nA
!+++          qqtil(japr,jthetapr,jz,jnu)=    &
!+++            &  splint(Aj_reduc(nAzero+1:nA_reduc),qqtil_reduc(nAzero+1:nA_reduc,jthetapr,jz,jnu), &
!+++            &  qqtil_reduc_2d(nAzero+1:nA_reduc,jthetapr,jz,jnu),Aj(japr))
!+++         end do
!+++       end do
!+++      end do
!+++     end do
!+++    deallocate(qqtil_reduc_2d,qqtil_reduc)
!+++!! spline over reduced function
!+++!      natspli=1.0E30_prec+small
!+++!     do jnu=1, nnu
!+++!      do jz=1, nz
!+++!       do jthetapr=0, ntheta
!+++!        call spline(Aj_reduc(1:nA_reduc),qqtil_reduc(1:nA_reduc,jthetapr,jz,jnu), &
!+++!            & natspli,natspli,qqtil_reduc_2d(1:nA,jthetapr,jz,jnu))
!+++!        end do
!+++!      end do
!+++!     end do
!+++!! recover price func over original grid
!+++!  do jnu= 1, nnu
!+++!   do jz= 1, nz
!+++!    do jthetapr= 0, ntheta
!+++!     do japr=1, nA
!+++!     qqtil(japr,jthetapr,jz,jnu)=    &
!+++!        &  splint(Aj_reduc(1:nA_reduc),qqtil_reduc(1:nA_reduc,jthetapr,jz,jnu), &
!+++!        &  qqtil_reduc_2d(1:nA_reduc,jthetapr,jz,jnu),Aj(japr))
!+++!     end do
!+++!    end do
!+++!   end do
!+++!  end do
! /////////////////////////////////


  errmaxq=maxval(abs(qqtilold(nAzero+1:nA,0:ntheta,1:nz,1:nnu) &
        & -qqtil_temp(nAzero+1:nA,0:ntheta,1:nz,1:nnu)))

  write(defout,*)      'errmaxq= ', errmaxq

    open(297, file='Qdiff_fig.dat') !03jun15
    write(297,'(3a3,a5,x,5a10)') 'jnu','jz','jthet', 'japr ',  'apr',  &
           &   'qqtil ', 'qqtilold ', &
           &   'abs(Q-Qold)', 'q*apr'
  do jnu= 1, nnu
   do jz= 1, nz
    do jthetapr= 0, ntheta
     do japr= nAzero, nA
       write(297,'(3i3,i5,x,f10.5,f10.5,f10.5,f10.5,f10.5)') jnu, jz, jthetapr, japr,    &
            & Aj(japr), &
           &   qqtil_temp(japr,jthetapr,jz,jnu), qqtilold(japr,jthetapr,jz,jnu), &
           &   abs(qqtil_temp(japr,jthetapr,jz,jnu)- qqtilold(japr,jthetapr,jz,jnu)), &
           &   qqtil_temp(japr,jthetapr,jz,jnu)*Aj(japr)
     end do
    end do
   end do
  end do
    close(297)


  deallocate (qqtilold,qqtil_temp)

  if (writeq.eq.1) call write_q

 end subroutine updques
! *********************************************************
 subroutine qqmap
! Globals:
!   qqtil
!   qq  (OUT)
!   delta
!   Aj Bj
!   nnu nz ntheta nA nB nAzero zero
!
! Local:
!   jnu, jz, jthetapr, jb
!   atarget
!   natspli
!
! Dependencies: use interp, lip
!               call spline
!               splint

  use interp
  implicit none
  integer :: jnu, jz, jthetapr, jb, ja
  real(prec) :: atarget
  real(prec), allocatable :: qqtil2d(:,:,:,:)
  real(prec) :: natspli

  allocate(qqtil2d(1:nA,0:ntheta,1:nz,1:nnu))

  if(interp_qtil.eq.2) then
  ! .. build spline for q ..
   natspli=1.0E30_prec+small
   do jnu= 1, nnu
    do jz=  1, nz
     do jthetapr= 0, ntheta
      call spline(Aj(1:nA),qqtil(1:nA,jthetapr,jz,jnu),natspli,natspli, &
            & qqtil2d(1:nA,jthetapr,jz,jnu))
     end do
    end do
   end do
  end if

  qq(1:nB,:,:,:,:)=zero
  do jnu= 1, nnu
   do jz=  1, nz
    do jthetapr= 0, ntheta
     do ja= 1, nA
      do jb= 1, nB
       if(jthetapr.eq.0) then
        atarget=max(Aj(nAzero),delta*Aj(ja)+Bj(jb))
        atarget=min(atarget,Aj(nA))
       else if(jthetapr.eq.1) then
        atarget=max(Aj(nAzero),Aj(ja)+Bj(jb))
        atarget=min(atarget,Aj(nA))
       else
         write(*,*) 'error: jtheta is not 0 or 1!! '
       end if

       if((atarget.ge.Aj(nAzero)).and.(atarget.le.Aj(nA))) then
        if(interp_qtil.eq.1) &
         & qq(jb,ja,jthetapr,jz,jnu)=  &
             &  lip(Aj(nAzero:nA),qqtil(nAzero:nA,jthetapr,jz,jnu),atarget)
        if(interp_qtil.eq.2) &
         & qq(jb,ja,jthetapr,jz,jnu)=splint(Aj(nAzero:nA),   &
         &      qqtil(nAzero:nA,jthetapr,jz,jnu),qqtil2d(nAzero:nA,jthetapr,jz,jnu),atarget)
       else
         write(*,*) 'error: atarget off bounds!! ', atarget
       end if
      end do
     end do
    end do
   end do
  end do


 deallocate(qqtil2d)

!    open(297, file='qq_fig.dat')
!    write(297,'(5a3,x,1a10)') 'jnu','jz','jthet', 'ja', 'jb',    &
!           &   'qq'
!  do jnu= 1, nnu
!   do jz= 1, nz
!    do jthetapr= 0, ntheta
!     do ja= 1, 1
!      do jb=1, nB
!       write(297,'(5i3,x,f10.5)') jnu, jz, jthetapr, ja, jb,    &
!           &   qq(jb,ja,jthetapr,jz,jnu)
!      end do
!     end do
!    end do
!   end do
!  end do
!    close(297)

 end subroutine qqmap

!*************************************************************
! [9.] Solve EQUIL PRICES
!*************************************************************
 subroutine prices_iter
! Globals: niter errmaxq errmaxH errmaxDEF errmaxBND tolall
!
! Locals: iter, iter1
!
! Dependencies: call updques qqmap agentD_opt
!               agentND_opt nobarg_iter lender_iter
!
  implicit none
  integer :: iter, iter1

  errmaxq=10.0_prec
  errmaxH=10.0_prec
  errmaxBND=10.0_prec
  errmaxDEF=10.0_prec
  errmaxV=10.0_prec

! ////////////////////////////////////////////
! Option [A.] Joint iteration
if(iter_option.eq.1) then
  iter=0
!  do while((iter.lt.niter).and. &
!    & (max(errmaxq,errmaxH0,errmaxH1,errmaxBND).gt.tolall).and. &
!    & errmaxD01.gt.0    )
  do while((iter.lt.niter))
    !if(iter.gt.200) speed_adjq=.01_prec

    if(iter.le.iter_switch_speedh) speed_adjh=speed_adjh1 !13oct21
    if(iter.gt.iter_switch_speedh) speed_adjh=speed_adjh2 !13oct21

   call updques
   call qqmap

   !call agent_iter
   call agentND_opt
   call agentD_opt
   call nobarg_iter

   call barg_iter

   if(useEV_in_barg.eq.0) then
   call barg_agentval
   end if

   call update_agentval

   call lender_iter
!stop !11jun21
   !call lender_theta1_iter

    write(outfile1,*) '---------------------------'
    write(outfile1,*) 'iter ', iter
    write(outfile1,*) 'errmaxq= ', errmaxq
    !write(outfile1,*) 'errmaxvD=', errmaxvD, 'errvD=', errvD
    !write(outfile1,*) 'errmaxvND=', errmaxvND, 'errvND=', errvND !10apr19
    write(outfile1,*) 'errmaxH=', errmaxH
    write(outfile1,*) 'errmaxBND=', errmaxBND
    write(outfile1,*) 'errmaxDEF=', errmaxDEF
    write(outfile1,*) 'errmaxV=', errmaxV

    iter=iter+1
  end do

    ! Temporarily here to study first-round barg w/o feedback
!    locaprB_ND(1:nA,1:nz,1:nnu)=1
!    call barg_nu1_ND
!    call barg_nu1_D
!    call barg_nu1
!    call barg_nu2_ND
!    call barg_nu2_D
!    call barg_nu2

!!    locaprB_ND(1:nA,1:nz,1:nnu)=1 !to ensure initalises locaprB_NDold within grids
!!! (2)
!!
!!  niter=200
!!  iter=0
!!  do while((iter.lt.niter))
!!   call updques
!!   call qqmap
!!   call agentND_opt
!!   call agentD_opt
!!   call nobarg_iter
!!
!!    call barg_nu1_ND
!!    call barg_nu1_D
!!    call barg_nu1
!!
!!    call barg_nu2_ND
!!    call barg_nu2_D
!!    call barg_nu2
!!   call barg_agentval
!!   call update_agentval
!!
!!   call lender_iter
!!   iter=iter+1
!!  end do


end if


! ////////////////////////////////////////////
! .. Converge in def and bND for given q ..
! Option [B.] Inner in def and bND; outer in q and H
!!**iter=0
!!**do while((iter.lt.niter))
!!**  ! -----------------------------------------------
!!**  ! Inner loop
!!**  ! -----------------------------------------------
!!**  errmaxBND=10.0_prec
!!**  errmaxDEF=10.0_prec
!!**  do while((errmaxBND.gt.tolall).or.(errmaxDEF.gt.tolall))
!!**
!!**   call agentND_opt
!!**   call agentD_opt
!!**   call nobarg_iter
!!**
!!**   call barg_iter
!!**   call barg_agentval
!!**
!!**   call update_agentval
!!**
!!**   !write(outfile1,*) 'errBND def=', errmaxBND, errmaxDEF
!!**
!!**  end do
!!**  ! -----------------------------------------------
!!**
!!**call lender_iter
!!**call updques
!!**call qqmap
!!**    write(outfile1,*) '---------------------------'
!!**    write(outfile1,*) 'iter ', iter
!!**    write(outfile1,*) 'errmaxq= ', errmaxq
!!**    !write(outfile1,*) 'errmaxvD=', errmaxvD, 'errvD=', errvD
!!**    !write(outfile1,*) 'errmaxvND=', errmaxvND, 'errvND=', errvND !10apr19
!!**    write(outfile1,*) 'errmaxH=', errmaxH
!!**    write(outfile1,*) 'errmaxBND=', errmaxBND
!!**    write(outfile1,*) 'errmaxDEF=', errmaxDEF
!!**
!!**    iter=iter+1
!!**
!!**end do

! ////////////////////////////////////////////
!
! .. Converge in q and H for given def and bND ..
! Option [C.] Inner in q and H! Outer in def and bND
if(iter_option.eq.2) then
iter=0
!!do while((iter.lt.niter))
do while((errmaxBND.gt.tol_defb).or.(errmaxDEF.gt.tol_defb))
  ! -----------------------------------------------
  ! Inner loop
  ! -----------------------------------------------
  errmaxq=10.0_prec
  errmaxH=10.0_prec
  write(outfile1,*)
  do while(max(errmaxq,errmaxH).gt.tolall)
    call lender_iter
    call updques
    call qqmap
   !write(outfile1,*) 'errq H=', errmaxq, errmaxH
  end do
  ! -----------------------------------------------

call agentND_opt
call agentD_opt
call nobarg_iter
call barg_iter
call barg_agentval
call update_agentval

    write(outfile1,*) '---------------------------'
    write(outfile1,*) 'iter ', iter
    write(outfile1,*) 'errmaxq= ', errmaxq
    !write(outfile1,*) 'errmaxvD=', errmaxvD, 'errvD=', errvD
    !write(outfile1,*) 'errmaxvND=', errmaxvND, 'errvND=', errvND !10apr19
    write(outfile1,*) 'errmaxH=', errmaxH
    write(outfile1,*) 'errmaxBND=', errmaxBND
    write(outfile1,*) 'errmaxDEF=', errmaxDEF

    iter=iter+1

end do
end if

! ////////////////////////////////////////////
!
! .. Converge in q and H then in def and bND ..
!
!!**iter=0
!!**do while((iter.lt.niter))
!!**
!!**  ! -----------------------------------------------
!!**  ! Inner loop
!!**  ! -----------------------------------------------
!!**  errmaxBND=10.0_prec
!!**  errmaxDEF=10.0_prec
!!**  do iter1=1, 5
!!**  !do while(errmaxBND.gt.tolall.or.errmaxDEF.gt.tolall)
!!**
!!**   call agentND_opt
!!**   call agentD_opt
!!**   call nobarg_iter
!!**
!!**   call barg_iter
!!**   call barg_agentval
!!**
!!**   call update_agentval
!!**
!!**   !write(outfile1,*) 'errBND def=', errmaxBND, errmaxDEF
!!**
!!**  end do
!!**  ! -----------------------------------------------
!!**    errmaxq=10.0_prec
!!**    errmaxH=10.0_prec
!!**    !do while(max(errmaxq,errmaxH).gt.tolall)
!!**    do iter1=1, 5
!!**    call lender_iter
!!**    call updques
!!**    call qqmap
!!**    end do
!!**
!!**        write(outfile1,*) '---------------------------'
!!**        write(outfile1,*) 'iter ', iter
!!**        write(outfile1,*) 'errmaxq= ', errmaxq
!!**        !write(outfile1,*) 'errmaxvD=', errmaxvD, 'errvD=', errvD
!!**        !write(outfile1,*) 'errmaxvND=', errmaxvND, 'errvND=', errvND !10apr19
!!**        write(outfile1,*) 'errmaxH=', errmaxH
!!**        write(outfile1,*) 'errmaxBND=', errmaxBND
!!**        write(outfile1,*) 'errmaxDEF=', errmaxDEF
!!**
!!**iter=iter+1
!!**
!!**end do


 end subroutine prices_iter

!*************************************************************
! [10.] WRITE IN/OUT FILES
!*************************************************************
 subroutine write_inout
 implicit none
    if (writev.eq.2) call write_v
    if (writeh.eq.2) call write_h
    if (writeq.eq.2) call write_q
 end subroutine write_inout


!*************************************************************
! [11.] WRITE FUNCTIONS
!*************************************************************
 subroutine write_functions
 implicit none
    call bycol_bND
    call bycol_qqtil
    call bycol_eqfunc
 end subroutine write_functions
!*************************************************************
 subroutine bycol_bND
!
! Globals: nB Bj qq BND_c
!
! Local: qq2d natspli
!        jthetapr jnu jz ja
!        bb qa
!
! Dependencies:
!    use interp
!    call spline
!    splint
!
  use interp
  implicit none

  integer :: jthetapr, jnu, jz, ja
  real(prec) :: natspli, bb ,qa
  real(prec), allocatable :: qq2d(:)
  CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/Replication/barg/bycol_figs/"
  allocate ( qq2d(1:nB))

  natspli=1.0E30_prec+small
  jthetapr=0

  open(297, file=fileplace//'bycol_bND.dat')
  write(297,'(2a3,a5,x,3a14)') 'jnu','jz','ja', 'a', 'BND ', 'qb'
  do jnu= 1, nnu
   do jz=  1, nz
    do ja= 1, nA
    natspli=1.0E30_prec+small
    call spline(Bj(1:nB),qq(1:nB,ja,jthetapr,jz,jnu), &
            & natspli,natspli,qq2d(1:nB) )
    bb=BND_c(ja,jz,jnu)
    qa=splint(Bj(1:nB),qq(1:nB,ja,jthetapr,jz,jnu),qq2d(1:nB),bb)
    write(297,'(2i3,i5,x,7f14.4)') jnu,jz,ja, Aj(ja), &
        &   bb, bb*qa
    end do
   end do
  end do
  close(297)
  deallocate(qq2d)
  end subroutine bycol_bND
!*************************************************************
 subroutine bycol_qqtil
!
! Globals: nnu nz ntheta nA nAzero
!          Aj qqtil
!
! Local: jthetapr jnu jz japr
!
 implicit none
 integer :: jthetapr, jnu, jz, japr
 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/Replication/barg/bycol_figs/"
 open(297, file=fileplace//'bycol_qqtil.dat')
 write(297,'(3a3,a5,x,2a10)') 'jnu','jz','jthet', 'japr ',  'apr',  &
           &   'qqtil'
  do jnu= 1, nnu
   do jz= 1, nz
    do jthetapr= 0, ntheta
     do japr= nAzero+1, nA
      if(qqtil(japr,jthetapr,jz,jnu).lt.500.0_prec) then
       write(297,'(3i3,i5,x,f10.5,f10.5)') jnu, jz, jthetapr, japr,    &
            & Aj(japr), &
           &   qqtil(japr,jthetapr,jz,jnu)
       else
       write(297,'(3i3,i5,x,f10.5,f10.5)') jnu, jz, jthetapr, japr,    &
            & Aj(japr), &
           &   500.0_prec
       end if
     end do
    end do
   end do
  end do
  close(297)
 end subroutine bycol_qqtil

!*************************************************************
 subroutine bycol_eqfunc
!
! Globals: nnu nz ntheta nA
!          DEF TT AA
!
! Local: jtheta jnu jz ja
!
 implicit none
 integer :: jtheta, jnu, jz, ja
 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/Replication/barg/bycol_figs/"

 open(297, file=fileplace//'bycol_eqfunc.dat')
 write(297,'(3a3,a5,x,a10,a10,4a10)') 'jthet','jnu','jz','ja','a',  &
 & 'def', 'TTd0', 'AAd0', 'TTd1', 'AAd1'
 do jtheta= 0, ntheta
  do jnu= 1, nnu
   do jz=  1, nz
    do ja= 1, nA
    write(297,'(3i3,i5,x,f10.5,f10.7,4f10.5)') jtheta, jnu, jz, ja, Aj(ja), &
    &   DEF(ja,jtheta,jz,jnu), &
    &   TT(ja,jtheta,jz,jnu,0),AA(ja,jtheta,jz,jnu,0), &
    &   TT(ja,jtheta,jz,jnu,1),AA(ja,jtheta,jz,jnu,1)
    end do
   end do
  end do
 end do
 close(297)
 end subroutine bycol_eqfunc


!**************************************************************
! [12.] SIMULATIONS AND DEFAULT EVENTS
!**************************************************************
subroutine simul_paths
 !
 ! Local: jz atarget jtheta jnu jthetapr jnupr
 !        seed, nshocks, ran_out
 !        a theta z nu d d01 b tau partdef q spread y c tb
 !        x_z x_nu x_d defaux qqqtil parsum
 !        vtemp_ND vtemp_D jalow jaup
 !        time ntime ntime_temp
 !        topcodedspr
 !
 !                  y_aver logy_var logy_corr
 !                  z_aver logz_aver logz_var logz_corr
 !                  a_aver b_aver d_aver defrate
 !                  cons_aver logc_aver logc_var
 !                  sdEX
 !                  logx_aver logx_stdv corrx
 !                  d_aver d_stdv spr_aver spr_stdv
 !                  logy_aver logy_stdv tb_aver tb_stdv
 !                  debtserv debtserv_stdv debt_stdv corr_dspr
 !                  corr_dy corr_tby corr_ddebttoY
 !                  debtdue   debtdue_stdv
 !                  debtserv_sd coupdef coupdef_sd coupdef_cond
 !                  coupdef_cond_sd
 !
 ! Global: nz zj Aj DEF BND_c TT qq AA
 !         q0 delta simulsize
 !
 ! Dependencies: call random_seed random_number
 !               use interp - lip blip psi
 !               call report_stats
 use interp
 implicit none

 real(prec) :: x_z, x_nu, x_d, defaux, qqqtil, parsum
 real(prec) :: vtemp_ND, vtemp_D
 integer :: jalow, jaup
 integer :: time, ntime, ntime_temp
 integer :: jz, jtheta, jnu, jzpr, jthetapr, jnupr, d01
 real(prec) :: atarget
 real(prec) :: vtemp_O, wtemp_D, wtemp_ND, vaux


 integer, parameter:: nshocks=3
 real(prec), dimension(:), allocatable:: ran_out
 integer, dimension(:), allocatable:: seed

 real(prec), dimension(:), allocatable :: a, z, tau, b, d, partdef, q, spread, y, c, tb
 integer, dimension(:), allocatable :: theta, nu

 real(prec) :: topcodedspr

 ! for use in [report_stats]

 real(prec) ::      y_aver,  &                                  !logy_var, logy_corr,
                 &  z_aver, logz_aver, logz_var, logz_corr, &
                 &  a_aver, b_aver, defrate, &
                 &  cons_aver, logc_aver, logc_var, &
                 &  sdEX, &
                 &  logx_aver, logx_stdv, corrx, &
                 &  d_aver,  &                                  !d_stdv, spr_aver, spr_stdv,
                 &  logy_aver, logy_stdv, tb_aver, tb_stdv, &
!12oct21         &  debtserv, debtserv_stdv, debtserv_sd, corr_dspr, &      !debt_stdv,
                 &  corr_dspr, &      !debt_stdv,
                 &  corr_dy, corr_tby, corr_ddebttoY
   real(prec) :: debtdue,   debtdue_stdv
   real(prec) :: coupdef, coupdef_sd, coupdef_cond, coupdef_cond_sd


 ! for use in [defaultevents] and [haircuts_extensions]
 integer, dimension(:), allocatable :: deftime0(:),deftime1(:)
 integer :: defcount, ndefcount
 integer, dimension(:), allocatable :: lengthdef(:)
 real(prec), dimension(:), allocatable :: averdef(:), averspr(:), averdebttoy(:), avery(:)
! real(prec), dimension(:), allocatable ::   &
!        & initdebttoy(:), finaldebttoy(:), middebttoy(:)
 real(prec), dimension(:), allocatable :: averhairc(:)
 real(prec) r_aux, del_aux

 real(prec), dimension(:), allocatable ::   &
   &   pre_initdebttoy     (:), &
   &   initdebttoy         (:), &
   &   middebttoy          (:), &
   &   finaldebttoy        (:), &
   &   post_finaldebttoy   (:)
 real(prec), dimension(:), allocatable ::   &
   &   pre_initdef     (:), &
   &   initdef         (:), &
   &   middef          (:), &
   &   finaldef        (:), &
   &   post_finaldef   (:), &
   &   pre_initspr     (:), &
   &   initspr         (:), &
   &   midspr          (:), &
   &   finalspr        (:), &
   &   post_finalspr   (:), &
   &   pre_inity       (:), &
   &   inity           (:), &
   &   midy            (:), &
   &   finaly          (:), &
   &   post_finaly     (:), &
   &   pre_initc       (:), &
   &   initc           (:), &
   &   midc            (:), &
   &   finalc          (:), &
   &   post_finalc     (:)

 real(prec) :: haircut_stat, extension_stat, &
!02dec21   &  length_aver_stat            , &
   &  length_sd_stat              , &
   &  corr_dlength_stat           , &
   &  corr_hairclength_stat       , &
   &  pre_initdebttoy_aver_stat   , &
   &  initdebttoy_aver_stat       , &
   &  middebttoy_aver_stat        , &
   &  finaldebttoy_aver_stat      , &
   &  post_finaldebttoy_aver_stat
 real(prec) ::  &
   &   pre_initdef_stat    , &
   &   initdef_stat        , &
   &   middef_stat         , &
   &   finaldef_stat       , &
   &   post_finaldef_stat  , &
   &   pre_initspr_stat    , &
   &   initspr_stat        , &
   &   midspr_stat         , &
   &   finalspr_stat       , &
   &   post_finalspr_stat  , &
   &   pre_inity_stat      , &
   &   inity_stat          , &
   &   midy_stat           , &
   &   finaly_stat         , &
   &   post_finaly_stat    , &
   &   pre_initc_stat      , &
   &   initc_stat          , &
   &   midc_stat           , &
   &   finalc_stat         , &
   &   post_finalc_stat

 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/Replication/barg/simul/"

 integer :: bad_def_theta0, bad_nodef_theta0, bad_def_theta1, bad_nodef_theta1 !29dec21
 integer :: def_theta0,nodef_theta0,def_theta1,nodef_theta1


 ntime=simulsize

 allocate(deftime0(ntime),deftime1(ntime))

 allocate (ran_out(nshocks))
 allocate (seed(nshocks))
 allocate (z(ntime),a(ntime),y(ntime),b(ntime),tau(ntime),d(ntime),c(ntime),q(ntime), &
    &   tb(ntime),spread(ntime), partdef(ntime), theta(ntime), nu(ntime))

 topcodedspr=111.11_prec

! ---------------------------------------------
! ---------------------------------------------
! Simulation
! ---------------------------------------------
! ---------------------------------------------

!29dec21
! Count efect of EV shocks:
    bad_def_theta0=0
    bad_nodef_theta0=0
    bad_def_theta1=0
    bad_nodef_theta1=0

    def_theta0=0
    def_theta1=0
    nodef_theta0=0
    nodef_theta1=0


!
! Initialise states
!
    jz=nz
    atarget=zero
    jtheta=0
    jnu=1

!
! Seeds
!
    seed = (/ 7654321, 7354541, 5353543 /) !for z and nu
    CALL random_seed(put=seed(1:nshocks))


    open (42, file=fileplace//'simulpaths.dat')
    !write(42,*) 'ntime ',  ntime
    write(42,*) ' --------------------'
    write(42,*) ' PATHS '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, thet, nu, b, d, c, spr '


!
! Loop over time
!

 do time=1, ntime
    !
    ! [0] States
    !
        z(time)=zj(jz)
        a(time)=min(atarget,Aj(nA)) !atarget
        theta(time)=jtheta
        nu(time)=jnu

    !
    ! [1] Exogenous stochastic shocks
    !
        call random_number(ran_out(1:nshocks))
        x_z=ran_out(1)
        x_nu=ran_out(2)
        x_d=ran_out(3)

    !
    ! [2] Current d01 and total default d
    !
!!        if(x_d.eq.one) then
!!         d(time)=zero*a(time)
!!         d01=0
!!        else if(x_d.eq.zero) then
!!         d(time)=one*a(time)
!!         d01=1
!!        else
!!         defaux=lip(Aj,DEF(:,jtheta,jz,jnu),a(time))
!!         if (x_d.le.defaux) then
!!            d(time)=one*a(time)
!!            d01=1
!!         else
!!            d(time)=zero*a(time)
!!            d01=0
!!         end if
!!        end if
!!        jthetapr=d01

    if(jtheta.eq.0) then
        if(x_d.eq.one) then
         d01=0
        else if(x_d.eq.zero) then
         d01=1
        else
         defaux=lip(Aj,DEF(:,jtheta,jz,jnu),a(time))
         if (x_d.le.defaux) then
            d01=1
            IF(defaux<0.5_prec)  bad_def_theta0=bad_def_theta0+1 !29dec21
         else
            d01=0
            IF(defaux>0.5_prec)  bad_nodef_theta0=bad_nodef_theta0+1 !29dec21
         end if
        end if
        if(d01.eq.1) def_theta0=def_theta0+1        !29dec21
        if(d01.eq.0) nodef_theta0=nodef_theta0+1    !29dec21
    end if


!13apr21: comment in when flag does not apply
if((barg_option.eq.0).or.(barg_option.eq.2)) then
    if(jtheta.eq.1) then
        !!tau(time)=lip(Aj,TT(:,jtheta,jz,jnu,d01),a(time))
        jalow=count(Aj.le.a(time))
        jaup=min(jalow+1,nA)

        if(DEF(jalow,jtheta,jz,jnu).ge.one-small) then        !when def is 0 or 1 for sure
            d01=1 !lip(Aj,DEF(:,jtheta,jz,jnu),a(time))
        else if(DEF(jaup,jtheta,jz,jnu).le.zero+small) then
            d01=0 !lip(Aj,DEF(:,jtheta,jz,jnu),a(time))

        else if( &                                            !if DEF interior (0,1)
            &   (DEF(jalow,jtheta,jz,jnu).gt.zero+small) &
            &   .or.    &
            &   (DEF(jaup,jtheta,jz,jnu).lt.one-small) ) then
                if(x_d.eq.one) then
                    d01=0
                else if(x_d.eq.zero) then
                    d01=1
                else
                defaux=lip(Aj,DEF(:,jtheta,jz,jnu),a(time))
                    if (x_d.le.defaux) then
                        d01=1
                        IF(defaux<0.5_prec)  bad_def_theta1=bad_def_theta1+1 !29dec21
                    else
                        d01=0
                        IF(defaux>0.5_prec)  bad_nodef_theta1=bad_nodef_theta1+1 !29dec21
                    end if
                end if

            if(d01.eq.1) def_theta1=def_theta1+1        !29dec21
            if(d01.eq.0) nodef_theta1=nodef_theta1+1    !29dec21

!        else                                            ! if def either 0 or 1, not for sure which
!        !12aug21
!        write(outfile1,*) 'simul if reached!! stop her'
!        stop
!            if(jnu.eq.1) then
!                vtemp_ND=lip(Aj,vB_ND(:,jz),a(time))
!                vtemp_D=lip(Aj,vB_D(:,jz),a(time))
!            end if
!            if(jnu.eq.2) then
!                vtemp_ND=lip(Aj,wB_ND(:,jz),a(time))
!                vtemp_D=lip(Aj,wB_D(:,jz),a(time))
!            end if
!            if ( vtemp_ND.ge.vtemp_D) then
!                d01=0
!            else
!                d01=1
!            end if

        end if
    end if
end if

!13apr21
if(barg_option.eq.1) then
    if(jtheta.eq.1) then
        jalow=count(Aj.le.a(time))
        jaup=min(jalow+1,nA)

        if(DEF(jalow,jtheta,jz,jnu).gt.one-small) then
            d01=1
        else if(DEF(jaup,jtheta,jz,jnu).lt.zero+small) then
            d01=0
        else

            if(jnu.eq.1) then
                vtemp_ND=lip(Aj,vB_ND(:,jz),a(time))
                vtemp_D=lip(Aj,vB_D(:,jz),a(time))
                vtemp_O=lip(Aj,vB_O_nu1(:,jz),a(time))
                if ( vtemp_ND.ge.vtemp_D) then
                    d01=0
                else
                    d01=1
                end if
            end if

            if(jnu.eq.2) then
                wtemp_ND=lip(Aj,wB_ND(:,jz),a(time))
                wtemp_D=lip(Aj,wB_D(:,jz),a(time))
                vtemp_ND=lip(Aj,vB_ND_nu2(:,jz),a(time))
                vtemp_D=lip(Aj,vB_D_nu2(:,jz),a(time))
                vtemp_O=lip(Aj,vB_O_nu2(:,jz),a(time))

                if(wtemp_D.le.wtemp_ND) then
                 vaux=vtemp_ND
                else
                 vaux=vtemp_D
                end if

                if(vtemp_O.lt.vaux) then
                    if(wtemp_ND.ge.wtemp_D) d01=0
                    if(wtemp_ND.lt.wtemp_D) d01=1
                else
                                            d01=0
                end if

            end if

        end if
    end if
end if


    tau(time)=lip(Aj,TT(:,jtheta,jz,jnu,d01),a(time))
    d(time)=a(time)-tau(time)

    jthetapr=d01

    !
    ! [3] endogenous decision and prices
    !
        if((jtheta.eq.0).and.(d01.eq.0)) then
         !b(time)=lip(Aj,BND_c(:,jz,jnu),a(time))
         b(time)=min(lip(Aj,BND_c(:,jz,jnu),a(time)), Bj(nB))
         b(time)=max(b(time),b(1)) !02jan22
        else
         b(time)=zero
        end if

!!        tau(time)=lip(Aj,TT(:,jtheta,jz,jnu,d01),a(time))
!!        if(a(time).gt.zero) then
!!         partdef(time)=one-tau(time)/a(time)
!!        else
!!         partdef(time)=zero
!!        end if
        if(a(time).gt.zero) then
            partdef(time)=d(time)/a(time)
        else
            partdef(time)=zero
        end if

!12aug21        if(theta(time).eq.1) then
!        if((theta(time).eq.1).or.(jthetapr.eq.1)) then
!         qqqtil=zero !12aug21 qqtil=zero
!        else
!         qqqtil=blip(Bj,Aj,qq(:,:,jthetapr,jz,jnu),b(time),a(time))
!        end if
!        q(time)=qqqtil

        qqqtil=blip(Bj,Aj,qq(:,:,jthetapr,jz,jnu),b(time),a(time)) !to have the notional value
        q(time)=qqqtil


!        spread(time)=zero
!        if(lip(Aj,AA(:,jtheta,jz,jnu,d01),a(time)).gt.small) then
!         spread(time)= (((one/qqqtil)+delta)**4.0_prec)  &
!            &       -((one/q0)**4.0_prec)
!         spread(time)=min(spread(time),11.11_prec)
!        end if
         if(qqqtil.le.small) then
            spread(time)= topcodedspr
         else
            spread(time)= (((one/qqqtil)+delta)**modelfreq)  &
            &       -((one/q0)**modelfreq)
         end if
!!         if(qqqtil.le.small) spread(time)= topcodedspr


        y(time)=zj(jz)*psi(jtheta,jz)
        c(time)=y(time)-tau(time)+qqqtil*b(time)
        tb(time)=y(time)-c(time)



        if(time.le.min(5000,ntime)) &
                    & write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & i3,i3,f10.6,f10.6, &
                    & f10.6,f30.12,f10.6)') &
            & time, y(time),  z(time), a(time),  &
            & theta(time), nu(time), b(time), d(time), &
            & c(time), spread(time), q(time)

!!*        if(time.le.min(5000,ntime)) &
!!*                    & write(42,'( &
!!*                    & i6,f10.6,f10.6,f10.6, &
!!*                    & i3,i3,f10.6,f10.6, &
!!*                    & f10.6,f30.12,f10.6)') &
!!*            & time, y(time),  z(time), a(time),  &
!!*            & theta(time), nu(time), b(time), d(time), &
!!*            & c(time), spread(time), q(time)

    !
    ! [4] Next-period states
    !

        atarget=lip(Aj,AA(:,jtheta,jz,jnu,d01),a(time))
        jtheta=jthetapr

        if(x_z.eq.one) then
            jzpr=nz
        else if(x_z.eq.zero) then
            jzpr=1
        else
        parsum=zero
            do jzpr=1, nz
             if((x_z.ge.parsum).and.(x_z.lt.parsum+piz(jz,jzpr)))  exit
             parsum=parsum+piz(jz,jzpr)
            end do
        end if
        jz=jzpr

        if(x_nu.eq.one) then
            jnupr=nnu
        else if(x_nu.eq.zero) then
            jnupr=1
        else
        parsum=zero
            do jnupr=1, nnu
             if((x_nu.ge.parsum).and.(x_nu.lt.parsum+pinu(jnu,jnupr)))  exit
             parsum=parsum+pinu(jnu,jnupr)
            end do
        end if
        jnu=jnupr



 end do !time
    close(42)


!29dec21
    write(outfile1,*)
    write(outfile1,*) ' Outcomes driven by EV shocks '
    write(outfile1,'(a25,i20)') ' ntime           ',  ntime
    write(outfile1,'(a25,i20)') ' bad_def_theta0  ',  bad_def_theta0
    write(outfile1,'(a25,i20)') ' bad_nodef_theta0',  bad_nodef_theta0
    write(outfile1,'(a25,i20)') ' bad_def_theta1  ',  bad_def_theta1
    write(outfile1,'(a25,i20)') ' bad_nodef_theta1',  bad_nodef_theta1
    write(outfile1,'(a25,i20)') ' def_theta0  ',  def_theta0
    write(outfile1,'(a25,i20)') ' nodef_theta0  ',  nodef_theta0
    write(outfile1,'(a25,i20)') ' def_theta1  ',  def_theta1
    write(outfile1,'(a25,i20)') ' nodef_theta1  ',  nodef_theta1

! ---------------------------------------------
! ---------------------------------------------
! Throw away the first 10% of observations
! ---------------------------------------------
! ---------------------------------------------
    ntime_temp=int(ntime*0.9)
    y(1:ntime_temp)=y(ntime-ntime_temp+1:ntime)
    z(1:ntime_temp)=z(ntime-ntime_temp+1:ntime)
    a(1:ntime_temp)=a(ntime-ntime_temp+1:ntime)
    b(1:ntime_temp)=b(ntime-ntime_temp+1:ntime)
    d(1:ntime_temp)=d(ntime-ntime_temp+1:ntime)
    c(1:ntime_temp)=c(ntime-ntime_temp+1:ntime)
    theta(1:ntime_temp)=theta(ntime-ntime_temp+1:ntime)
    nu(1:ntime_temp)=nu(ntime-ntime_temp+1:ntime)
    spread(1:ntime_temp)=spread(ntime-ntime_temp+1:ntime)
    tb(1:ntime_temp)=tb(ntime-ntime_temp+1:ntime)
    partdef(1:ntime_temp)=partdef(ntime-ntime_temp+1:ntime)
    ! .. reset ..
    ntime=ntime_temp


! ---------------------------------------------
! ---------------------------------------------
! Outcomes depending on model's frequency
! ---------------------------------------------
! ---------------------------------------------


open(47, file='final_stats.dat') !10feb21

if(int(modelfreq).eq.4) then
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'QUARTERLY DATA'
    write(outfile1,*) '--------------------'
    write(outfile1,*)
        call report_stats
        call simulpaths_stats
        call defaultevents
        r_aux=((one/q0))-one
        del_aux=delta
    if(ndefcount.gt.2) then !15oct21
        call haircuts_extensions(r_aux,del_aux)
        call slope_coeffs
    end if
        write(47,*) '---------------'
        write(47,*) 'QUARTERLY DATA'
        write(47,*) '---------------'
        call final_stats

 deallocate(lengthdef,averdef)
 deallocate(averspr)
 deallocate(averdebttoy,avery)
 deallocate(averhairc) !25jul18
 deallocate(initdebttoy, finaldebttoy, middebttoy) !10jan19
 deallocate(pre_initdebttoy, post_finaldebttoy) !09feb21
 deallocate(   &
   &   pre_initdef     , &
   &   initdef         , &
   &   middef          , &
   &   finaldef        , &
   &   post_finaldef   , &
   &   pre_initspr     , &
   &   initspr         , &
   &   midspr          , &
   &   finalspr        , &
   &   post_finalspr   , &
   &   pre_inity       , &
   &   inity           , &
   &   midy            , &
   &   finaly          , &
   &   post_finaly     , &
   &   pre_initc       , &
   &   initc           , &
   &   midc            , &
   &   finalc          , &
   &   post_finalc          )

    write(outfile1,*) '--------------------'
    write(outfile1,*) 'ANNUAL DATA'
    write(outfile1,*) '--------------------'
    write(outfile1,*)
        call annualdata
        call report_stats
        call simulpaths_yr_stats
        call defaultevents
        r_aux=((one/q0)**modelfreq)-one
        del_aux=(one+r_aux)*((((one/q0)/((one/q0)-delta))/modelfreq)-one) &
            & /(((one/q0)/((one/q0)-delta))/modelfreq)
    if(ndefcount.gt.2) then !15oct21
        call haircuts_extensions(r_aux,del_aux) !20jul18

        !!call haircbyvintage(r_aux,del_aux) !(((one/q0)**modelfreq)-one,delta**modelfreq)
        call slope_coeffs !25jul18 !11feb17
        call split_by_default !01apr17
    end if
        write(47,*) '---------------'
        write(47,*) 'ANNUAL DATA'
        write(47,*) '---------------'
        call final_stats
end if


if(int(modelfreq).eq.1) then
        call report_stats
        call simulpaths_stats
        call defaultevents
        r_aux=((one/q0))-one
        del_aux=delta
    if(ndefcount.gt.2) then !15oct21
        call haircuts_extensions(r_aux,del_aux)
        !!call haircbyvintage(r_aux,del_aux)
        call slope_coeffs
        call split_by_default
    end if
        write(47,*) '---------------'
        write(47,*) 'ANNUAL DATA'
        write(47,*) '---------------'
        call final_stats
end if


!    write(outfile1,*) '--------------------'
!    write(outfile1,*) 'ANNUAL NOW DATA'
!    write(outfile1,*) '--------------------'
!    write(outfile1,*)
!    call report_stats
!    !!call defaultevents
!    !! r_aux=((one/q0))-one
!    !! del_aux=delta
!    !! call haircuts_extensions(r_aux,del_aux)
!    !! call slope_coeffs
!
!    !!deallocate(lengthdef,averdef)
!    !!deallocate(averspr)
!    !!deallocate(averdebttoy,avery)
!    !!deallocate(initdebttoy, finaldebttoy, middebttoy)
!    !!deallocate(averhairc)

! ---------------------------------------------
! ---------------------------------------------
! Outcomes at not-model's frequency (annual)
! ---------------------------------------------
! ---------------------------------------------

!!    write(outfile1,*) '--------------------'
!!    write(outfile1,*) 'ANNUAL DATA'
!!    write(outfile1,*) '--------------------'
!!    write(outfile1,*)
!!
!!    call annualdata
!!    call report_stats
!!    !!call defaultevents
!!    !!r_aux=((one/q0)**4.0_prec)-one
!!    !!del_aux=(one+r_aux)*((((one/q0)/((one/q0)-delta))/4.0_prec)-one) &
!!    !!    & /(((one/q0)/((one/q0)-delta))/4.0_prec)
!!    !! call haircuts_extensions(r_aux,del_aux)
!!    !! call haircbyvintage(r_aux,del_aux)
!!    !! call slope_coeffs
!!    !! call split_by_default


close(47)


    deallocate(ran_out,seed)
    deallocate(z,a,y,b,d,c,q,tb,spread,partdef,theta,nu)

 contains
!------------------------------------------------------------------------------
subroutine report_stats
 !
 ! Globals: a_aver2
 !          freqdef arrears AtoY Spr
 !          sdC
 !          corrSpr sdSpr corr_sprtb
 !          smalldef
 !
 !
 ! Global (host):   y_aver logy_var logy_corr
 !                  zaver logz_aver logz_var logz_corr
 !                  a_aver b_aver d_aver defrate
 !                  cons_aver logc_aver logc_var
 !                  sdEX
 !                  logx_aver logx_stdv corrx
 !                  d_aver d_stdv spr_aver spr_stdv d_aver d_stdv
 !                  logy_aver logy_stdv tb_aver tb_stdv
 !                  debtserv debtserv_stdv debt_stdv corr_dspr
 !                  corr_dy corr_tby corr_ddebttoY
 ! Local:
 !
 implicit none


 ! .. Statistics ..

    write(outfile1,*) '--------------------'
    write(outfile1,*) 'MODEL INDICATORS '
    write(outfile1,*) '--------------------'
    write(outfile1,*)

    y_aver=sum(y(1:ntime))/real(ntime)
    logy_aver=sum(log(y(1:ntime)))/real(ntime)
    logy_var=sum((log(y(1:ntime))-logy_aver)**(2.0_prec))/real(ntime)
    logy_stdv=sqrt(sum((log(y(1:ntime))-logy_aver)*(log(y(1:ntime))-logy_aver))/real(ntime))

    logy_corr=(sum((( log(y(2:ntime)))-logy_aver)*((log(y(1:ntime-1)))-logy_aver))/real(ntime-1) )/ &
        & (logy_var)
    z_aver=sum(z(1:ntime))/real(ntime)
    logz_aver=sum(log(z(1:ntime)))/real(ntime)
    logz_var=sum((log(z(1:ntime))-logz_aver)**(2.0_prec))/real(ntime)
    logz_corr=(sum((( log(z(2:ntime)))-logz_aver)*((log(z(1:ntime-1)))-logz_aver))/real(ntime-1) )/ &
        & (logz_var)

    a_aver= sum(a(1:ntime))/real(ntime)
    a_aver2=a_aver
    b_aver= sum(b(1:ntime))/count(theta(1:ntime).eq.0)
    d_aver= sum(d(1:ntime),d(1:ntime).gt.zero)/count(d(1:ntime).gt.zero)            !repeated below
    defrate=sum(d(1:ntime)/a(1:ntime),a(1:ntime).gt.zero)/count(d(1:ntime).gt.zero)

    cons_aver=sum(c(1:ntime))/real(ntime)
    logc_aver=sum(log(c(1:ntime)))/real(ntime)
    logc_var=sum((log(c(1:ntime))-logc_aver)**(2.0_prec))/real(ntime)

    write(outfile1,*)
    write(outfile1,'(a35,f9.4)') 'Average inc ', y_aver
    write(outfile1,'(a35,f9.4)') 'Variance log inc ', logy_var
    write(outfile1,'(a35,f9.4)') 'Sd log inc ', sqrt(logy_var)
    write(outfile1,'(a35,f9.4)') 'Autocorr log inc ', logy_corr !26may15
    write(outfile1,*)
    write(outfile1,'(a35,f9.4)') 'Average z ', z_aver
    write(outfile1,'(a35,f9.4)') 'Variance log z ', logz_var
    write(outfile1,'(a35,f9.4)') 'Sd log z ', sqrt(logz_var)
    write(outfile1,'(a35,f9.4)') 'Autocorr log z ', logz_corr

    write(outfile1,*)
    write(outfile1,'(a35,f9.4)') 'Average a ', a_aver
    write(outfile1,*)
    write(outfile1,'(a35,f9.4)') 'Average b if theta=0      ', b_aver
    write(outfile1,'(a35,f9.4)') 'Average value def (if d>0) ', d_aver
    write(outfile1,'(a35,f9.4)') 'Aver def rate (if D>0) ', defrate
    write(outfile1,'(a25,f9.4)') 'Def freq (d>0 cond a>0) ',real(count(d(1:ntime).ge.Aj(nAzero+1)))/real(count(a(1:ntime).gt.Aj(nAzero+1)))
    write(outfile1,*)
    write(outfile1,'(a25,f9.4)') 'Average cons ', cons_aver
    write(outfile1,'(a25,f9.4)') 'Variance log cons ', logc_var

    write(outfile1,*)
    write(outfile1,*) ' Grids binding? '
    write(outfile1,'(a25,f12.8)') '% Bmin ', real(count(b(1:ntime).le.(Bj(1) +gridB_dist/two)))/real(ntime)
    write(outfile1,'(a25,f12.8)') '% Amax ', real(count(a(1:ntime).ge.(Aj(nA)-gridA_dist/two)))/real(ntime)
    write(outfile1,'(a25,f12.8)') '% Bmax ', real(count(b(1:ntime).ge.(Bj(nB)-gridB_dist/two)))/real(ntime)

    write(outfile1,*)
    write(outfile1,*) ' Max and min realised: '
    write(outfile1,'(a25,f12.8)') 'Amin ', minval(a(1:ntime))
    write(outfile1,'(a25,f12.8)') 'Amax ', maxval(a(1:ntime))
    write(outfile1,'(a25,f12.8)') 'Bmin ', minval(b(1:ntime))
    write(outfile1,'(a25,f12.8)') 'Bmax ', maxval(b(1:ntime))
    write(outfile1,'(a25,f12.8)') 'spr max ', maxval(spread(1:ntime))


    write(outfile1,*)
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'MAIN AVERAGES '
    write(outfile1,*) '--------------------'
    write(outfile1,*)

    freqdef=real(count(d(1:ntime).gt.zero+small))/real(ntime)
    !arrears=sum(d(1:ntime)/a(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
    arrears=sum(d(1:ntime)/a(1:ntime),d(1:ntime).gt.zero+small)/max(small,real(count(d(1:ntime).gt.zero+small))) !15oct21
    AtoY=sum(a(1:ntime)/y(1:ntime))/real(ntime) !23jun17 (sum(a(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime))
    Spr=sum(spread(1:ntime),spread(1:ntime).lt.topcodedspr)/count(spread(1:ntime).lt.topcodedspr)
    !(sum(spread(1:ntime))/real(ntime))

    ! .. consumption ..
    logx_aver=sum(log(c(1:ntime)))/real(ntime)
    logx_stdv=sqrt(sum((log(c(1:ntime))-logx_aver)*(log(c(1:ntime))-logx_aver))/real(ntime))
    corrx=   (sum((log(c(1:ntime))-logx_aver)*(log(y(1:ntime))-logy_aver))/real(ntime))/(logx_stdv*logy_stdv)
    sdC=logx_stdv/logy_stdv

    ! .. trade (as proport of Y)..
    logx_aver=sum((tb(1:ntime)/y(1:ntime)))/real(ntime)
    logx_stdv=sqrt(sum(((tb(1:ntime)/y(1:ntime))-logx_aver)*((tb(1:ntime)/y(1:ntime))-logx_aver))/real(ntime))
    corrx=   (sum(((tb(1:ntime)/y(1:ntime))-logx_aver)*(log(y(1:ntime))-logy_aver))/real(ntime))/(logx_stdv*logy_stdv)
    sdEX=logx_stdv/logy_stdv !24sep13

    ! .. spread ..
    logx_aver=sum(spread(1:ntime),spread(1:ntime).lt.topcodedspr)/real(count(spread(1:ntime).lt.topcodedspr))
    logx_stdv=sqrt(sum(((spread(1:ntime))-logx_aver)*((spread(1:ntime))-logx_aver), &
        & spread(1:ntime).lt.topcodedspr)/real(count(spread(1:ntime).lt.topcodedspr)))
    corrx=  ( sum(((spread(1:ntime))-logx_aver)*(log(y(1:ntime))-logy_aver), &
        &spread(1:ntime).lt.topcodedspr)/real(count(spread(1:ntime).lt.topcodedspr)))/(logx_stdv*logy_stdv)
    sdSpr=logx_stdv
    corrSpr=corrx

    !spr_aver=sum(spread(1:ntime))/real(ntime)
    !spr_stdv=sqrt(sum((spread(1:ntime)-spr_aver)*(spread(1:ntime)-spr_aver))/real(ntime))
    spr_aver=sum(spread(1:ntime),spread(1:ntime).lt.topcodedspr)/real(count(spread(1:ntime).lt.topcodedspr))
    spr_stdv=sqrt(sum((spread(1:ntime)-spr_aver)*(spread(1:ntime)-spr_aver),spread(1:ntime).lt.topcodedspr) &
        &   /max(small,real(count(spread(1:ntime).lt.topcodedspr)))) !15oct21
    tb_aver=sum(((tb(1:ntime)/y(1:ntime)))/real(ntime))
    tb_stdv=sqrt(sum(((tb(1:ntime)/y(1:ntime))-tb_aver)*((tb(1:ntime)/y(1:ntime))-tb_aver), &
        &   spread(1:ntime).lt.topcodedspr)/real(count(spread(1:ntime).lt.topcodedspr)))
    corr_sprtb= &
     & ( sum(((spread(1:ntime))-spr_aver)*(tb(1:ntime)/y(1:ntime)-tb_aver), &
     &      spread(1:ntime).lt.topcodedspr)/real(count(spread(1:ntime).lt.topcodedspr))) &
     &  /(spr_stdv*tb_stdv)

    write(outfile1,*)
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'TABLE MAIN RESULTS '
    write(outfile1,*) '--------------------'
   write(outfile1,*)
   write(outfile1,*) ' .. MEANS | arrears >0 .. '
   write(outfile1,'(a30,a10,f9.5)') 'partial default', '(D/A)', arrears
   write(outfile1,'(a30,a10,f9.5)') 'debt due/output', '(A/Y)', &
                & (sum(a(1:ntime)/y(1:ntime),d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))
   write(outfile1,'(a30,a10,f9.5)') 'new loans/output B>0', '(qB/Y)', &
                &  (sum(q(1:ntime)*b(1:ntime)/y(1:ntime), &
                &   (d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small)) &
                &   /real(count((d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small))) )
   write(outfile1,'(a30,a10,f9.5)') 'new loans/output' , '(qB/Y)', &
                &  (sum(q(1:ntime)*b(1:ntime)/y(1:ntime), &
                &   d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)))
   write(outfile1,'(a30,a10,f9.5)') 'spread B>0', ' ', (sum(spread(1:ntime), &
                & (d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small)) &
                & /real(count((d(1:ntime).gt.zero+small).and.(b(1:ntime).gt.zero+small))))
   write(outfile1,'(a30,a10,f9.5)') 'coupons def/output' , '(D/Y)', sum(d(1:ntime)/y(1:ntime), &
                & d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
   write(outfile1,'(a30,a10,f9.5)') 'debt service/output' , ' ', sum((a(1:ntime)-d(1:ntime))/y(1:ntime), &
                & d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small))
   write(outfile1,'(a30,a10,f9.5)') 'debt/output' , ' ', &      !16jan15
                & (sum(a(1:ntime)/y(1:ntime),d(1:ntime).gt.zero+small) &
                &       /real(count(d(1:ntime).gt.zero+small)))/((one-q0*delta)*modelfreq)

   write(outfile1,*)
   write(outfile1,*) ' .. MEANS OVERALL .. '
   write(outfile1,'(a30,a10,f9.5)') 'freq arrears>0', '  ', freqdef
   write(outfile1,'(a30,a10,f9.5)') 'debt service/output', 'A/Y', (sum(a(1:ntime)/y(1:ntime))/real(ntime))
   write(outfile1,'(a30,a10,f9.5)') 'new loans/output B>0', '(qB/Y)', &
                &  (sum(q(1:ntime)*b(1:ntime)/y(1:ntime), &
                &   (b(1:ntime).gt.zero+small)) &
                &   /real(count((b(1:ntime).gt.zero+small))) )
   write(outfile1,'(a30,a10,f9.5)') 'new loans/output' , '(qB/Y)', &
                &  (sum(q(1:ntime)*b(1:ntime)/y(1:ntime))/real(ntime))
   write(outfile1,'(a30,a10,f9.5)') 'spread |apr>0', ' ', (sum(spread(1:ntime-1), &
                & (a(2:ntime).ge.small).and.(spread(1:ntime-1).lt.topcodedspr) ) &
                & /real(count((a(2:ntime).ge.small).and.(spread(1:ntime-1).lt.topcodedspr))))
   write(outfile1,'(a30,a10,f9.5)') 'spread B>0', ' ', (sum(spread(1:ntime), &
                & (b(1:ntime).gt.zero+small).and.(spread(1:ntime).lt.topcodedspr)) &
                & /real(count((b(1:ntime).gt.zero+small))))
   write(outfile1,'(a30,a10,f9.5)') 'coupons def/output' , '(D/Y)', &
                & sum(d(1:ntime)/y(1:ntime)) /real(ntime)
   write(outfile1,'(a30,a10,f9.5)') 'debt service/output' , ' ', sum((a(1:ntime)-d(1:ntime))/y(1:ntime) &
                & ) /real(ntime)
   write(outfile1,'(a30,a10,f9.5)') 'debt/output' , ' ', &
                & (sum(a(1:ntime)/y(1:ntime)) &
                &       /real(ntime))/((one-q0*delta)*modelfreq)



   write(outfile1,*)
   write(outfile1,*) ' .. BUSINESS CYCLES (oct 2014) .. '
    d_aver=sum(partdef(1:ntime),d(1:ntime).gt.zero+small)/ &
        & real(count((d(1:ntime).gt.zero+small)))
!    d_stdv=sqrt(sum(((partdef(1:ntime)-d_aver)*(partdef(1:ntime)-d_aver)),((d(1:ntime).gt.zero+small)))&
!        & /real(count(((d(1:ntime).gt.zero+small)))))
    d_stdv=sqrt(sum(((partdef(1:ntime)-d_aver)*(partdef(1:ntime)-d_aver)),((d(1:ntime).gt.zero+small)))&
        & /max(small,real(count(((d(1:ntime).gt.zero+small)))))) !15oct21
    spr_aver=sum(spread(1:ntime),(d(1:ntime).gt.zero+small).and.(spread(1:ntime).lt.topcodedspr)) &
        & /real(count((d(1:ntime).gt.zero+small).and.(spread(1:ntime).lt.topcodedspr)))
    spr_stdv=sqrt(sum((spread(1:ntime)-spr_aver)*(spread(1:ntime)-spr_aver), &
        &   (d(1:ntime).gt.zero+small).and.(spread(1:ntime).lt.topcodedspr) )&
        & /max(small,real(count((d(1:ntime).gt.zero+small).and.(spread(1:ntime).lt.topcodedspr))))   ) !15oct21
    coupdef_cond=sum(d(1:ntime)/y(1:ntime), &
                & d(1:ntime).gt.zero+small)/real(count(d(1:ntime).gt.zero+small)) !10feb21
    coupdef_cond_sd=sqrt(sum(((d(1:ntime))/y(1:ntime)-coupdef_cond) &                  !10feb21
        &                   *((d(1:ntime))/y(1:ntime)-coupdef_cond), &
        &           d(1:ntime).gt.zero+small)   &
        &     /max(small,real(count(d(1:ntime).gt.zero+small))) ) !15oct21

!11apr18  IF(ID==0) THEN !10jan18
   write(outfile1,*) 'DISPERSION D>0: '
   write(outfile1,'(a30,a10,f9.5)') 'sd part default', '  ',    d_stdv
   write(outfile1,'(a30,a10,f9.5)') 'sd spread', '  ',    spr_stdv
   write(outfile1,'(a30,a10,f9.5)') 'sd coupon def/Y', '  ', coupdef_cond_sd
!11apr18 END IF

   ! ...................................................................
    d_aver=sum(partdef(1:ntime))/real(ntime)
    d_stdv_noncond =sqrt(sum((partdef(1:ntime)-d_aver)*(partdef(1:ntime)-d_aver))/real(ntime))
    spr_aver=sum(spread(1:ntime),(spread(1:ntime).lt.topcodedspr)) &
        & /real(count((spread(1:ntime).lt.topcodedspr)))
    spr_stdv=sqrt(sum((spread(1:ntime)-spr_aver)*(spread(1:ntime)-spr_aver), &
        &   (spread(1:ntime).lt.topcodedspr) )&
        & /real(count((spread(1:ntime).lt.topcodedspr))))
    logy_aver=sum(log(y(1:ntime)))/real(ntime)
    logy_stdv=sqrt(sum((log(y(1:ntime))-logy_aver)*(log(y(1:ntime))-logy_aver))/real(ntime))
    tb_aver=sum((tb(1:ntime)/y(1:ntime)))/real(ntime) !17oct14
    tb_stdv=sqrt(sum(((tb(1:ntime)/y(1:ntime))-tb_aver)*((tb(1:ntime)/y(1:ntime))-tb_aver))/real(ntime)) !17oct14

    debtserv=sum((a(1:ntime)-d(1:ntime))/y(1:ntime))/real(ntime)
    debtserv_sd=sqrt(sum(((a(1:ntime)-d(1:ntime))/y(1:ntime)-debtserv) &
        &               *((a(1:ntime)-d(1:ntime))/y(1:ntime)-debtserv)) &
        &                   /real(ntime))
    coupdef=sum(d(1:ntime)/y(1:ntime))/real(ntime)
    coupdef_sd=sqrt(sum(((d(1:ntime))/y(1:ntime)-coupdef) &
        &               *((d(1:ntime))/y(1:ntime)-coupdef)) &
        &                   /real(ntime))


!11apr18  IF(ID==0) THEN !10jan18
   write(outfile1,*) 'DISPERSION Overall D : '
   write(outfile1,'(a30,a10,f9.5)') 'sd part default', '  ',    d_stdv_noncond
   write(outfile1,'(a30,a10,f9.5)') 'sd spread', '  ',    spr_stdv
   write(outfile1,'(a30,a10,f9.5)') 'sd C/sd logy', '  ',        sdC
   write(outfile1,'(a30,a10,f9.5)') 'sd exports/Y /sd logy', '  ',  sdEX
!11apr18 END IF
!14feb17 - sd debt due to ouput
   debtdue=(sum(a(1:ntime)/y(1:ntime))/real(ntime))
   debtdue_stdv=sqrt(sum((a(1:ntime)/y(1:ntime)-debtdue)*(a(1:ntime)/y(1:ntime)-debtdue))/real(ntime))
   debt_stdv= debtdue_stdv/((one-q0*delta)*modelfreq)
!11apr18  IF(ID==0) THEN !10jan18
   write(outfile1,'(a30,a10,f9.5)') 'sd debt due/output', '  ',    debtdue_stdv
   write(outfile1,'(a30,a10,f9.5)') 'sd debt /output', '  ',    &
    & debtdue_stdv/((one-q0*delta)*modelfreq) !14jun17
   write(outfile1,'(a30,a10,f9.5)') 'sd coupon def/Y', '  ', coupdef_sd !10feb21
   write(outfile1,'(a30,a10,f9.5)') 'sd debt service', '  ', debtserv_sd !10feb21
!11apr18 END IF

    corr_dspr=  ( sum(((partdef(1:ntime))-d_aver)*(spread(1:ntime)-spr_aver), &
            & spread(1:ntime).lt.topcodedspr) / &
            & real(count(spread(1:ntime).lt.topcodedspr)))/(d_stdv_noncond*spr_stdv)
    corr_dy=  ( sum(((partdef(1:ntime))-d_aver)*(log(y(1:ntime))-logy_aver))/ &
            & real(ntime))/(d_stdv_noncond*logy_stdv)
    corr_tby=  ( sum((tb(1:ntime)/y(1:ntime)-tb_aver)*(log(y(1:ntime))-logy_aver))/ &
            & real(ntime))/(tb_stdv*logy_stdv)

    corr_ddebttoY=( sum(((partdef(1:ntime))-d_aver)*((a(1:ntime)/y(1:ntime))-debtdue))/ &
            & real(ntime) )/(d_stdv_noncond*debtdue_stdv)

!11apr18  IF(ID==0) THEN !10jan18
   write(outfile1,*) 'CORRELATIONS Overall D : '

   write(outfile1,'(a30,a10,f9.5)') 'corr partdefault spread', '  ',   corr_dspr
   write(outfile1,'(a30,a10,f9.5)') 'corr y spread', '  ',          corrSpr
   write(outfile1,'(a30,a10,f9.5)') 'corr exports spread', '  ',    corr_sprtb
   write(outfile1,'(a30,a10,f9.5)') 'corr partdefault logy', '  ',   corr_dy
   write(outfile1,'(a30,a10,f9.5)') 'corr exports/y logy', '  ',    corr_tby
   write(outfile1,'(a30,a10,f9.5)') 'corr partdefault debttoY', '  ',   corr_ddebttoY

   write(outfile1,'(a30,a10,f9.5)') 'corr spread debttoY', '  ', &
        & ( sum(((spread(1:ntime))-spr_aver)*((a(1:ntime)/y(1:ntime))-debtdue), &
        &   (spread(1:ntime).lt.topcodedspr))/ &
        &   real(count(spread(1:ntime).lt.topcodedspr)) )/(spr_stdv*debtdue_stdv)
! ----------------------------------------------------------------------------
!03oct15
    write(outfile1,*)
    write(outfile1,*) '--------------------'
    write(outfile1,*) 'NEW CALIBRATION TARGETS '
    write(outfile1,*) '--------------------'
       write(outfile1,*)
       write(outfile1,'(7a9,5a9,a9)') 'Psimin', 'phi1',  'beta ',  &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'smalld'
       write(outfile1,'(7f9.4,3f9.6,f9.5,f9.5,f9.5)')  Psimin, phi1,  beta,   &
        & AtoY, Spr, freqdef, arrears, &
        & d_stdv, spr_stdv, &
        & debt_stdv, &
        & corrSpr, sdC, smalldef

!11apr18 END IF
 end subroutine report_stats
!------------------------------------------------------------------------------
 subroutine simulpaths_stats
 implicit none
  CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/Replication/barg/simul/"
  open(297, file=fileplace//'simulpaths_stats.dat')
  write(297,'(a14,a14,a14)') 'y_aver'
  write(297,'(f14.6,f14.6,f14.6)') y_aver
  close(297)
 end subroutine simulpaths_stats

 subroutine simulpaths_yr_stats
 implicit none
  CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/Replication/barg/simul/"
  open(297, file=fileplace//'simulpaths_yr_stats.dat')
  write(297,'(a14)') 'y_aver'
  write(297,'(f14.6)') y_aver
  close(297)
 end subroutine simulpaths_yr_stats
!------------------------------------------------------------------------------
 subroutine defaultevents
 implicit none

    integer :: time
    integer :: maxlengthdef, tdefevent, lengthtarget
    real(prec), allocatable :: y_defevent(:), z_defevent(:), &
        & a_defevent(:), b_defevent(:), &
        & spread_defevent(:), partdef_defevent(:)
    integer, allocatable  :: nsurvivedef(:)
    real(prec), allocatable :: c_defevent(:) !03mar19

    CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/Replication/barg/events/"
    character (len=2) :: lengthtarg_c
!   .. parametsr for Matlab filea ..
    open(297, file=fileplace//'defeventsparam.dat')
    write(297,'(a14,a14,a14,a14)') 'delta', 'q0', 'freq', 'zaver_glob'
    write(297,'(f14.6,f14.6,f14.6,f14.6)') delta, q0, modelfreq, zaver_glob
    close(297)

!  .. Find when def events begin and end ..
 deftime0=1
 deftime1=1


 defcount=0
 do time =1, ntime
    if(defcount.eq.0) then
     if( (partdef(time).gt.zero+small)) then
        defcount=defcount+1
        deftime0(defcount)=time
     end if
    else
     if( (partdef(time).gt.zero+small).and. &
       & (partdef(time-1).le.zero+small )) then
        defcount=defcount+1
        deftime0(defcount)=time
     end if
    end if
 end do


 defcount=0
 do time =1, ntime-1
     if( (partdef(time).gt.zero+small).and. &
       & (partdef(time+1).le.zero+small )) then
        defcount=defcount+1
        deftime1(defcount)=time
     end if
 end do

 ndefcount=defcount

! build variables for episodes: lenght, aver def, and spr

 allocate(lengthdef(ndefcount),averdef(ndefcount))
 allocate(averspr(ndefcount))
 allocate(averdebttoy(ndefcount),avery(ndefcount))

allocate(  &
   &    initdebttoy(ndefcount), &
   &    finaldebttoy(ndefcount),&
   &    middebttoy(ndefcount), &
   &    pre_initdebttoy(ndefcount),  &
   &    post_finaldebttoy(ndefcount)    )
allocate(   &
   &   pre_initdef     (ndefcount), &
   &   initdef         (ndefcount), &
   &   middef          (ndefcount), &
   &   finaldef        (ndefcount), &
   &   post_finaldef   (ndefcount), &
   &   pre_initspr     (ndefcount), &
   &   initspr         (ndefcount), &
   &   midspr          (ndefcount), &
   &   finalspr        (ndefcount), &
   &   post_finalspr   (ndefcount), &
   &   pre_inity       (ndefcount), &
   &   inity           (ndefcount), &
   &   midy            (ndefcount), &
   &   finaly          (ndefcount), &
   &   post_finaly     (ndefcount), &
   &   pre_initc       (ndefcount), &
   &   initc           (ndefcount), &
   &   midc            (ndefcount), &
   &   finalc          (ndefcount), &
   &   post_finalc     (ndefcount)     )

 do defcount=1, ndefcount
 lengthdef(defcount)= deftime1(defcount)-deftime0(defcount)+1
 averdef(defcount)=sum(partdef(deftime0(defcount):deftime1(defcount))) &
        & /real(lengthdef(defcount))
 averspr(defcount)=sum(spread(deftime0(defcount):deftime1(defcount))) &
        & /real(lengthdef(defcount))
 averdebttoy(defcount)=sum( &
        & a(deftime0(defcount):deftime1(defcount))/y(deftime0(defcount):deftime1(defcount)) &
        & ) &
        & /real(lengthdef(defcount))

!10jan19
! initdebttoy(defcount)= &
!    & a(deftime0(defcount))/y(deftime0(defcount))
! finaldebttoy(defcount)= &
!    & a(deftime1(defcount))/y(deftime1(defcount))
! middebttoy(defcount)= &
!    & a( int((deftime0(defcount)+deftime1(defcount))/two) )  &
!    & / y( int((deftime0(defcount)+deftime1(defcount))/two)  )
 pre_initdebttoy(defcount)= &
    & a(max(1,deftime0(defcount)-1))/y(max(1,deftime0(defcount)-1))
 initdebttoy(defcount)= &
    & a(deftime0(defcount))/y(deftime0(defcount))
 middebttoy(defcount)= &
    & a( int((deftime0(defcount)+deftime1(defcount))/two) )  &
    & / y( int((deftime0(defcount)+deftime1(defcount))/two)  )
 finaldebttoy(defcount)= &
    & a(deftime1(defcount))/y(deftime1(defcount))
 post_finaldebttoy(defcount)= &
    & a(min(deftime1(defcount)+1,ntime))/y(min(deftime1(defcount)+1,ntime))

 pre_initdef(defcount)= &
    & partdef(max(1,deftime0(defcount)-1))
 initdef(defcount)= &
    & partdef(deftime0(defcount))
 middef(defcount)= &
    & partdef( int((deftime0(defcount)+deftime1(defcount))/two) )
 finaldef(defcount)= &
    & partdef(deftime1(defcount))
 post_finaldef(defcount)= &
    & partdef(min(deftime1(defcount)+1,ntime))

 pre_initspr(defcount)= &
    & spread(max(1,deftime0(defcount)-1))
 initspr(defcount)= &
    & spread(deftime0(defcount))
 finalspr(defcount)= &
    & spread(deftime1(defcount))
 midspr(defcount)= &
    & spread( int((deftime0(defcount)+deftime1(defcount))/two) )
 post_finalspr(defcount)= &
    & spread(min(deftime1(defcount)+1,ntime))

 pre_inity(defcount)= &
    & log(y(max(1,deftime0(defcount)-1)))-log(y_aver)
 inity(defcount)= &
    & log(y(deftime0(defcount)))-log(y_aver)
 finaly(defcount)= &
    & log(y(deftime1(defcount)))-log(y_aver)
 midy(defcount)= &
    & log(y(int((deftime0(defcount)+deftime1(defcount))/two) ))-log(y_aver)
 post_finaly(defcount)= &
    & log(y(min(deftime1(defcount)+1,ntime)))-log(y_aver)

 pre_initc(defcount)= &
    & log(c(max(1,deftime0(defcount)-1)))-log(cons_aver)
 initc(defcount)= &
    & log(c(deftime0(defcount)))-log(cons_aver)
 finalc(defcount)= &
    & log(c(deftime1(defcount)))-log(cons_aver)
 midc(defcount)= &
    & log(c(int((deftime0(defcount)+deftime1(defcount))/two) ))-log(cons_aver)
 post_finalc(defcount)= &
    & log(c(min(deftime1(defcount)+1,ntime)))-log(cons_aver)

 avery(defcount)=sum( &
        & log(y(deftime0(defcount):deftime1(defcount))) &
        & ) &
        & /real(lengthdef(defcount)) !22jun17

 end do

!    open(42, file='events.dat')
!    write(42,*) ' --------------------'
!    write(42,*) ' PATHS '
!    write(42,*) ' --------------------'
!    write(42,*) 'time, theta, a, partdef '
!        do defcount=1, ndefcount
!            write(42,*)
!            do tdefevent=deftime0(defcount),deftime1(defcount)
!                write(42,'(i4,f14.8,f14.8)') &
!                    & theta(tdefevent), a(tdefevent), partdef(tdefevent)
!            end do
!        end do
!    close(42)


! .. construct analysis of default events ..

if(doEVENT.eq.1) then

!19jun17
   maxlengthdef=maxval(lengthdef(1:ndefcount))
   allocate(nsurvivedef(0:maxlengthdef), &
        & y_defevent(0:maxlengthdef), &
        & z_defevent(0:maxlengthdef), &
        & a_defevent(0:maxlengthdef), &
        & b_defevent(0:maxlengthdef), &
        & spread_defevent(0:maxlengthdef), &
        & partdef_defevent(0:maxlengthdef) &
        & )
!19jun17
    !first event is defcount=2 to ensure there is a previous no-def period
    ! Event period zero, where def is zero
    nsurvivedef(0)=ndefcount-1
    y_defevent(0)=sum(y(deftime0(2:ndefcount)-1))
    y_defevent(0)=y_defevent(0)/real(ndefcount-1)
    z_defevent(0)=sum(z(deftime0(2:ndefcount)-1))
    z_defevent(0)=z_defevent(0)/real(ndefcount-1)
    a_defevent(0)=sum(a(deftime0(2:ndefcount)-1))
    a_defevent(0)=a_defevent(0)/real(ndefcount-1)
    b_defevent(0)=sum(b(deftime0(2:ndefcount)-1))
    b_defevent(0)=b_defevent(0)/real(ndefcount-1)
    spread_defevent(0)=sum(spread(deftime0(2:ndefcount)-1))
    spread_defevent(0)=spread_defevent(0)/real(ndefcount-1)
    partdef_defevent(0)=sum(partdef(deftime0(2:ndefcount)-1))
    partdef_defevent(0)=partdef_defevent(0)/real(ndefcount-1)

    do tdefevent=1, maxlengthdef
     nsurvivedef(tdefevent)=count(lengthdef(2:ndefcount).ge.tdefevent)
     y_defevent(tdefevent)= &
        & sum(y(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     y_defevent(tdefevent)=y_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     z_defevent(tdefevent)= &
        & sum(z(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     z_defevent(tdefevent)=z_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     a_defevent(tdefevent)= &
        & sum(a(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     a_defevent(tdefevent)=a_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     b_defevent(tdefevent)= &
        & sum(b(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     b_defevent(tdefevent)=b_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     spread_defevent(tdefevent)= &
        & sum(spread(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     spread_defevent(tdefevent)=spread_defevent(tdefevent)/real(nsurvivedef(tdefevent))
     partdef_defevent(tdefevent)= &
        & sum(partdef(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).ge.tdefevent)
     partdef_defevent(tdefevent)=partdef_defevent(tdefevent)/real(nsurvivedef(tdefevent))
    end do

    open(42, file='defevents.dat')
    write(42,*) ' --------------------'
    write(42,*) ' PATHS '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, partdef, spr, probexit '
        do tdefevent=0, maxlengthdef
        write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, &
                    & f10.6)') &
            & tdefevent, y_defevent(tdefevent),  z_defevent(tdefevent), a_defevent(tdefevent),  &
            & b_defevent(tdefevent), partdef_defevent(tdefevent), &
            & spread_defevent(tdefevent),  &
            & one-real(nsurvivedef(tdefevent))/real(ndefcount-1)
        end do
    close(42)

!19jun17
    deallocate(nsurvivedef,y_defevent,z_defevent, &
        & a_defevent,b_defevent,spread_defevent,partdef_defevent)


else if(doEVENT.eq.2) then
    ! Events of an exact duration lengthdef(defcount).eq.lengthtarget
    !first possible event is defcount=2 to ensure there is a previous no-def period
    ! Event period zero, where def is zero

    ! set length
    lengthtarget=lengthevent !3

   allocate(nsurvivedef(0:maxlengthdef), &
        & y_defevent(0:lengthtarget), &
        & z_defevent(0:lengthtarget), &
        & a_defevent(0:lengthtarget), &
        & b_defevent(0:lengthtarget), &
        & spread_defevent(0:lengthtarget), &
        & partdef_defevent(0:lengthtarget) &
        & )
   allocate( c_defevent(0:lengthtarget)) !03mar19

    nsurvivedef(0)=count(lengthdef(2:ndefcount).eq.lengthtarget)
    y_defevent(0)=sum(y(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    y_defevent(0)=y_defevent(0)/real(nsurvivedef(0))
    z_defevent(0)=sum(z(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    z_defevent(0)=z_defevent(0)/real(nsurvivedef(0))
    a_defevent(0)=sum(a(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    a_defevent(0)=a_defevent(0)/real(nsurvivedef(0))
    b_defevent(0)=sum(b(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    b_defevent(0)=b_defevent(0)/real(nsurvivedef(0))
    spread_defevent(0)=sum(spread(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    spread_defevent(0)=spread_defevent(0)/real(nsurvivedef(0))
    partdef_defevent(0)=sum(partdef(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    partdef_defevent(0)=partdef_defevent(0)/real(nsurvivedef(0))

    !03mar19
    c_defevent(0)=sum(c(deftime0(2:ndefcount)-1), &
            & (lengthdef(2:ndefcount).eq.lengthtarget))
    c_defevent(0)=c_defevent(0)/real(nsurvivedef(0))

!24jul18     do tdefevent=1, lengthtarget
    do tdefevent=1, lengthtarget+1 !24jul18
     y_defevent(tdefevent)= &
        & sum(y(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     y_defevent(tdefevent)=y_defevent(tdefevent)/real(nsurvivedef(0))
     z_defevent(tdefevent)= &
        & sum(z(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     z_defevent(tdefevent)=z_defevent(tdefevent)/real(nsurvivedef(0))
     a_defevent(tdefevent)= &
        & sum(a(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     a_defevent(tdefevent)=a_defevent(tdefevent)/real(nsurvivedef(0))
     b_defevent(tdefevent)= &
        & sum(b(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     b_defevent(tdefevent)=b_defevent(tdefevent)/real(nsurvivedef(0))
     spread_defevent(tdefevent)= &
        & sum(spread(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     spread_defevent(tdefevent)=spread_defevent(tdefevent)/real(nsurvivedef(0))
     partdef_defevent(tdefevent)= &
        & sum(partdef(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     partdef_defevent(tdefevent)=partdef_defevent(tdefevent)/real(nsurvivedef(0))

    !03mar19
     c_defevent(tdefevent)= &
        & sum(c(deftime0(2:ndefcount)+tdefevent-1),  &
        &   lengthdef(2:ndefcount).eq.lengthtarget)
     c_defevent(tdefevent)=c_defevent(tdefevent)/real(nsurvivedef(0))
    end do

    if(lengthtarget.ge.10) write(lengthtarg_c,'(i2)') lengthtarget
    if(lengthtarget.lt.10) write(lengthtarg_c,'(i1)') lengthtarget
    open(42, file=fileplace//'defevents_lenyr'//trim(lengthtarg_c)//'.dat')
    !open(42, file='defevents_lenyr.dat')
    write(42,*) ' --------------------'
    write(42,*) ' PATHS '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, partdef, spr, cons  '
!24jul18        do tdefevent=0, lengthtarget
        do tdefevent=0, maxlengthevent+1
        !do tdefevent=0, lengthtarget+1 !24jul18
!        write(42,'( &
!                    & i6,f10.6,f10.6,f10.6, &
!                    & f10.6,f10.6, &
!                    & f10.6, f10.6 &
!                    & )') &
!            & tdefevent, y_defevent(tdefevent),  z_defevent(tdefevent), a_defevent(tdefevent),  &
!            & b_defevent(tdefevent), partdef_defevent(tdefevent), &
!            & spread_defevent(tdefevent), c_defevent(tdefevent) !03mar19
        if((tdefevent.le.lengthtarget+1).and.(spread_defevent(tdefevent).lt.topcodedspr-small)) then
        write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6, f10.6 &
                    & )') &
            & tdefevent, y_defevent(tdefevent),  z_defevent(tdefevent), a_defevent(tdefevent),  &
            & b_defevent(tdefevent), partdef_defevent(tdefevent), &
            & spread_defevent(tdefevent), c_defevent(tdefevent) !03mar19
        else if(tdefevent.le.lengthtarget+1) then
        write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & a10, f10.6 &
                    & )') &
            & tdefevent, y_defevent(tdefevent),  z_defevent(tdefevent), a_defevent(tdefevent),  &
            & b_defevent(tdefevent), partdef_defevent(tdefevent), &
            & 'NaN', c_defevent(tdefevent) !03mar19
        else
        write(42,'( i6,7a10)') &
            & tdefevent, 'NaN', 'NaN', 'NaN', 'NaN', 'NaN', 'NaN', 'NaN'
        end if

        end do
    close(42)

    deallocate(nsurvivedef,y_defevent,z_defevent, &
        & a_defevent,b_defevent,spread_defevent,partdef_defevent, &
        & c_defevent) !03mar19

else if (doEVENT.eq.3) then
! Histogram of length of default

  maxlengthdef=maxval(lengthdef(1:ndefcount))
  allocate(nsurvivedef(0:maxlengthdef))
  do lengthtarget=1, maxlengthdef
    nsurvivedef(lengthtarget)=count(lengthdef(1:ndefcount).eq.lengthtarget)
  end do
    open(42, file='histoglength.dat')
    write(42,*) ' --------------------'
    write(42,*) ' HISTOGRAM '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, partdef, spr, probexit '
        do lengthtarget=1, maxlengthdef
        write(42,'( &
                    & i6,f10.6 &
                    &           )') &
            & lengthtarget, real(nsurvivedef(lengthtarget))/real(ndefcount)
        end do
    close(42)
    deallocate(nsurvivedef)
end if
 end subroutine defaultevents
!------------------------------------------------------------------------------
 subroutine haircuts_extensions(r_yr, del_yr)
 implicit none

 real(prec) r_yr, del_yr, aL, aNEW
 integer :: time
 real(prec) :: valOLD_aver,durOLD_aver,valNEW_aver,durNEW_aver

 real(prec), dimension(:), allocatable :: valOLD(:), durOLD(:), &
        &                   valNEW(:), durNEW(:), &
        &                   hairc(:), extens(:)
    !These variables will later go global in [defaultevents]

 integer :: lengthtarget, maxlengthdef
 real(prec) ::  haircut_bylength, extens_bylength, valOLD_bylength, durOLD_bylength
 integer ::     nevents_bylength


    allocate(valOLD(ndefcount),durOLD(ndefcount), &
        & valNEW(ndefcount),durNEW(ndefcount))

 allocate(averhairc(ndefcount-1)) !25jul18

 valOLD=zero
 durOLD=zero
 valNEW=zero
 durNEW=zero

  averhairc=zero !25jul18

 ! delta_yr=delta**4, r_yr=1-(1+r)^4 with 1+r=1/q0

 do defcount=1, ndefcount-1
 ! .. Compute duration of event defcount ..
 ! Need:
 ! partdef(deftime0(defcount):deftime1(defcount))
 ! b(deftime0(defcount):deftime1(defcount))
 ! RRbar(deftime0(defcount):deftime1(defcount))
 ! a(deftime0(defcount):deftime1(defcount))
 ! a(deftime1(defcount)+1)
 ! length(defcount)




    !
    ! .. Defaulted debts ..
    !
!!    do time=deftime0(defcount),deftime1(defcount)
!!    valOLD(defcount)= valOLD(defcount) &
!!            &   +(partdef(time)*a(time)) &
!!            &       / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))
!!    durOLD(defcount)=durOLD(defcount) &
!!            &   +   (real(time-deftime0(defcount)+1)) &
!!            &     * (partdef(time)*a(time)) &
!!            &       / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))
!!    end do
!!    durOLD(defcount)=durOLD(defcount)/valOLD(defcount)

!21jun21: need to adapt the above
    valOLD(defcount)=a(deftime0(defcount))*((1+r_yr)/(one+r_yr-del_yr))
    durOLD(defcount)=(1+r_yr)/(one+r_yr-del_yr)



    !
    ! .. Arrears paid ..
    !
!    aL=a(deftime0(defcount))
    aNEW=zero
    if(deftime1(defcount).ge.deftime0(defcount)+1) then
     do time=deftime0(defcount)+1,deftime1(defcount)

!!      aNEW=(one-del_yr)*RRbar(time-1)*partdef(time-1)*a(time-1)+del_yr*aNEW
    !21jun21: adapt the above
    if(time.lt.deftime1(defcount)) then
        aNEW=zero
    else
        aNEW=a(time)
    end if

      ! or (one-del_yr)*one*a(time-1)?
      valNEW(defcount)= valNEW(defcount) &
        &   + ((one-partdef(time))* aNEW )&
        &   / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))

      durNEW(defcount)= durNEW(defcount) &
        &   + real(time-deftime0(defcount)+1) &
        &   * ((one-partdef(time))* aNEW )&
        &   / ((one+r_yr)**(real(time-deftime0(defcount)+1-1)))

     end do
    end if

       aNEW=a(min(deftime1(defcount)+1,ntime))  !21jun21: adapted
       valNEW(defcount)= valNEW(defcount) &
        & + ((one+r_yr)/(one+r_yr-del_yr)) &
        &   * ( (aNEW )&
        & / ((one+r_yr)**(real(deftime1(defcount)-deftime0(defcount)+1))) )

      durNEW(defcount)= durNEW(defcount) &
        &   + ( (aNEW )&
        &  / ((one+r_yr)**(real(deftime1(defcount)-deftime0(defcount)+1))) ) &
        &   *(       &
        &       (real(deftime1(defcount)-deftime0(defcount)+1)) &
        &           * ((one+r_yr)/(one+r_yr-del_yr)) &
        &       +(one/((one-(del_yr/(one+r_yr)))**(two))) &
        &       )

      durNEW(defcount)= durNEW(defcount)/valNEW(defcount)

      averhairc(defcount)=one-valNEW(defcount)/valOLD(defcount) !25jul18

!!!    write(outfile1,*) valNEW(defcount)/valOLD(defcount),  RRbar(deftime1(defcount)), partdef(deftime1(defcount))

 end do



    valOLD_aver=sum(valOLD(1:ndefcount-1))/real(ndefcount-1)
    durOLD_aver=sum(durOLD(1:ndefcount-1))/real(ndefcount-1)
    valNEW_aver=sum(valNEW(1:ndefcount-1))/real(ndefcount-1)
    durNEW_aver=sum(durNEW(1:ndefcount-1))/real(ndefcount-1)


    write(outfile1,*)
!15sep18
 write(outfile1,*)
 write(outfile1,*)
 write(outfile1,*) 'delta = ', delta, 'r  = ',  (one/q0)-one
 write(outfile1,*) 'riskfree duration quarterly freq', &
    &   (one/q0)/((one/q0)-delta)
 write(outfile1,*) 'delta adj= ', del_yr, 'r adj = ',  r_yr
 write(outfile1,*) 'riskfree duration adjusted freq (x4 if annual)', &
    &   (one+r_yr)/(one+r_yr-del_yr)
    write(outfile1,*) 'delta= ', del_yr, 'r = ',  r_yr
    write(outfile1,*) 'HAIRCUTS AND MATURITY EXTENSIONS '
    write(outfile1,*) 'aver valOLD', valOLD_aver
    write(outfile1,*) 'aver durOLD', durOLD_aver
    write(outfile1,*) 'aver valNEW', valNEW_aver
    write(outfile1,*) 'aver durNEW', durNEW_aver
! haircut_bylength=zero
! do defcount=1, ndefcount-1
!    haircut_bylength=haircut_bylength+one-valNEW(defcount)/valOLD(defcount)
! end do

    haircut_stat= one - sum((valNEW(1:ndefcount-1)/valOLD(1:ndefcount-1)))/real(ndefcount-1) !10feb21
    hhaircut=haircut_stat
    write(outfile1,*) 'haircut', haircut_stat !10feb21
    write(outfile1,*) 'haircut (2)', sum(averhairc(1:ndefcount-1))/real(ndefcount-1) !25jul18

    write(outfile1,*) 'max/min haircut', one-minval(valNEW(1:ndefcount-1)/valOLD(1:ndefcount-1)), one-maxval(valNEW(1:ndefcount-1)/valOLD(1:ndefcount-1))
    extension_stat=sum(durNEW(1:ndefcount-1)-durOLD(1:ndefcount-1))/real(ndefcount-1) !10feb21
    write(outfile1,*) 'extension', extension_stat !10feb21



 write(outfile1,*) 'HAIRCUTS AND EXTENSIONS BY LENGTH '
 write(outfile1,'(a7,a9,a9,a9,a9)') &
            &       'length', 'valOLD', 'durOLD', &
            &       'haircut', 'extens'


 maxlengthdef=maxval(lengthdef(1:ndefcount-1))

 do lengthtarget=1, min(10,maxlengthdef)

 haircut_bylength=zero
 extens_bylength=zero
 valOLD_bylength=zero
 durOLD_bylength=zero
 nevents_bylength=count(lengthdef(1:ndefcount-1).eq.lengthtarget)
 do defcount=1, ndefcount-1
 if(lengthdef(defcount).eq.lengthtarget) then
    haircut_bylength=haircut_bylength+ &
        & (one-valNEW(defcount)/valOLD(defcount))
    extens_bylength=extens_bylength+ &
        &   durNEW(defcount)-durOLD(defcount)
    valOLD_bylength=valOLD_bylength+ &
        &   valOLD(defcount)
    durOLD_bylength=durOLD_bylength+ &
        &   durOLD(defcount)
 end if
 end do
 haircut_bylength=haircut_bylength/real(nevents_bylength)
 extens_bylength =extens_bylength/real(nevents_bylength)
 valOLD_bylength=valOLD_bylength/real(nevents_bylength)
 durOLD_bylength=durOLD_bylength/real(nevents_bylength)

 write(outfile1,'(i7,f9.5,f9.5,f9.5,f9.5)') &
            &       lengthtarget, valOLD_bylength, durOLD_bylength, &
            &       haircut_bylength, extens_bylength

 end do

 end subroutine haircuts_extensions

!------------------------------------------------------------------------------
!11feb17
subroutine slope_coeffs
use Percentile_mod !12may18
implicit none

 real(prec), dimension(:), allocatable :: rlengthdef(:) !12may18

 integer :: time
!21jun17 integer :: deftime0(ntime),deftime1(ntime)
!21jun17 integer :: defcount, ndefcount
!21jun17 real(prec), dimension(:), allocatable :: averdef(:), averspr(:)
!21jun17 integer, dimension(:), allocatable :: lengthdef(:)
 real(prec), dimension(:), allocatable :: x_mat(:,:), y_mat(:)
 real(prec) :: beta(2)
 real(prec) :: length_aver, def_aver, length_sd, def_sd, corr_dlength !14feb17
 real(prec) :: length_median     !12may18
 real(prec) :: spr_aver, spr_sd, corr_sprlength
 real(prec) :: debttoy_aver, debttoy_sd, corr_debttoylength !22jun17
 real(prec) :: y_aver, y_sd, corr_ylength
 real(prec) :: hairc_aver, hairc_sd, corr_hairclength   !25jul18

 real(prec) ::   initdebttoy_aver,          &
              &  finaldebttoy_aver,         &
              &  middebttoy_aver,           &
              &  pre_initdebttoy_aver,      &
              &  post_finaldebttoy_aver
 real(prec) ::  &
   &   pre_initdef_aver    , &
   &   initdef_aver        , &
   &   middef_aver         , &
   &   finaldef_aver       , &
   &   post_finaldef_aver  , &
   &   pre_initspr_aver    , &
   &   initspr_aver        , &
   &   midspr_aver         , &
   &   finalspr_aver       , &
   &   post_finalspr_aver  , &
   &   pre_inity_aver      , &
   &   inity_aver          , &
   &   midy_aver           , &
   &   finaly_aver         , &
   &   post_finaly_aver    , &
   &   pre_initc_aver      , &
   &   initc_aver          , &
   &   midc_aver           , &
   &   finalc_aver         , &
   &   post_finalc_aver
!19jun17
!21jun17    integer :: maxlengthdef, tdefevent
!21jun17    real(prec), allocatable :: y_defevent(:), z_defevent(:), &
!21jun17        & a_defevent(:), b_defevent(:), &
!21jun17        & spread_defevent(:), partdef_defevent(:)
!21jun17    integer, allocatable  :: nsurvivedef(:)




    write(outfile1,*) '******************************************'
    write(outfile1,*) ' SLOPE COEFFICIENTS OF  PARTIAL DEF '


! ---------------------------------------
! .. Default against lenght of default ..
! ---------------------------------------

!  construct regression objects
 allocate(x_mat(ndefcount,2),y_mat(ndefcount))
 x_mat(1:ndefcount,1)=one

! x_mat(1:ndefcount,2)=real(lengthdef(1:ndefcount))
! y_mat(1:ndefcount)=averdef(1:ndefcount)
! call OLS(ndefcount,2,x_mat,y_mat,beta)

    write(outfile1,*)
    write(outfile1,*) 'number of episodes', ndefcount, 'perods', ntime

!14feb17
! length default episode; corr part def - length episode
    length_aver=sum(lengthdef(1:ndefcount))/max(small,real(ndefcount))
    def_aver=sum(averdef(1:ndefcount))/max(small,real(ndefcount))
    length_sd=sqrt(sum((lengthdef(1:ndefcount)-length_aver)*(lengthdef(1:ndefcount)-length_aver))/max(small,real(ndefcount)))
    def_sd=sqrt(sum((averdef(1:ndefcount)-def_aver)*(averdef(1:ndefcount)-def_aver))/max(small,real(ndefcount)))
    corr_dlength=  ( sum(((averdef(1:ndefcount))-def_aver)*(lengthdef(1:ndefcount)-length_aver))/ &
            & max(small,real(ndefcount)))/(def_sd*length_sd)
    allocate(rlengthdef(ndefcount)) !12may18
    rlengthdef=real(lengthdef)!12may18
    call Percentile(ndefcount,rlengthdef,0.50_prec,length_median)   !12may18
    deallocate(rlengthdef)

!14jun17
    spr_aver=sum(averspr(1:ndefcount))/max(small,real(ndefcount))
    spr_sd=sqrt(sum((averspr(1:ndefcount)-spr_aver) &
        &   *(averspr(1:ndefcount)-spr_aver))/max(small,real(ndefcount)))
    corr_sprlength=( sum(((averspr(1:ndefcount))-spr_aver) &
        &                *(lengthdef(1:ndefcount)-length_aver))/ &
            & max(small,real(ndefcount)))/(spr_sd*length_sd)

!22jun17
! Create: averdebttoy(1:ndefcount)
! Define: debttoy_aver, debttoy_sd, corr_debttoylength
   debttoy_aver=sum(averdebttoy(1:ndefcount))/max(small,real(ndefcount))
   debttoy_sd=sqrt(sum((averdebttoy(1:ndefcount)-debttoy_aver) &
        &   *(averdebttoy(1:ndefcount)-debttoy_aver))/max(small,real(ndefcount)))
   corr_debttoylength=( sum(((averdebttoy(1:ndefcount))-debttoy_aver) &
        &                *(lengthdef(1:ndefcount)-length_aver))/ &
            & max(small,real(ndefcount)))/(debttoy_sd*length_sd)
! Create: avery(1:ndefcount)
! Define: y_aver, y_sd, corr_ylength
   y_aver=sum(avery(1:ndefcount))/max(small,real(ndefcount))
   y_sd=sqrt(sum((avery(1:ndefcount)-y_aver) &
        &   *(avery(1:ndefcount)-y_aver))/max(small,real(ndefcount)))
   corr_ylength=( sum(((avery(1:ndefcount))-y_aver) &
        &                *(lengthdef(1:ndefcount)-length_aver))/ &
            & max(small,real(ndefcount)))/(y_sd*length_sd)

    pre_initdebttoy_aver    = sum(pre_initdebttoy   (1:ndefcount))/max(small,real(ndefcount))
    initdebttoy_aver        = sum(initdebttoy       (1:ndefcount))/max(small,real(ndefcount))
    middebttoy_aver         =sum(middebttoy         (1:ndefcount))/max(small,real(ndefcount))
    finaldebttoy_aver       = sum(finaldebttoy      (1:ndefcount))/max(small,real(ndefcount))
    post_finaldebttoy_aver  = sum(post_finaldebttoy (1:ndefcount))/max(small,real(ndefcount))
    pre_initdebttoy_aver    =pre_initdebttoy_aver/((one-q0*delta)*modelfreq)
    initdebttoy_aver        =initdebttoy_aver/((one-q0*delta)*modelfreq)
    middebttoy_aver         =middebttoy_aver/((one-q0*delta)*modelfreq)
    finaldebttoy_aver       =finaldebttoy_aver/((one-q0*delta)*modelfreq)
    post_finaldebttoy_aver  =post_finaldebttoy_aver/((one-q0*delta)*modelfreq)

    pre_initdef_aver    = sum(pre_initdef   (1:ndefcount))/max(small,real(ndefcount))
    initdef_aver        = sum(initdef       (1:ndefcount))/max(small,real(ndefcount))
    middef_aver         = sum(middef        (1:ndefcount))/max(small,real(ndefcount))
    finaldef_aver       = sum(finaldef      (1:ndefcount))/max(small,real(ndefcount))
    post_finaldef_aver  = sum(post_finaldef (1:ndefcount))/max(small,real(ndefcount))
    pre_initspr_aver    = sum(pre_initspr   (1:ndefcount))/max(small,real(ndefcount))
    initspr_aver        = sum(initspr       (1:ndefcount))/max(small,real(ndefcount))
    midspr_aver         = sum(midspr        (1:ndefcount))/max(small,real(ndefcount))
    finalspr_aver       = sum(finalspr      (1:ndefcount))/max(small,real(ndefcount))
    post_finalspr_aver  = sum(post_finalspr (1:ndefcount))/max(small,real(ndefcount))
    pre_inity_aver      = sum(pre_inity     (1:ndefcount))/max(small,real(ndefcount))
    inity_aver          = sum(inity         (1:ndefcount))/max(small,real(ndefcount))
    midy_aver           = sum(midy          (1:ndefcount))/max(small,real(ndefcount))
    finaly_aver         = sum(finaly        (1:ndefcount))/max(small,real(ndefcount))
    post_finaly_aver    = sum(post_finaly   (1:ndefcount))/max(small,real(ndefcount))
    pre_initc_aver      = sum(pre_initc     (1:ndefcount))/max(small,real(ndefcount))
    initc_aver          = sum(initc         (1:ndefcount))/max(small,real(ndefcount))
    midc_aver           = sum(midc          (1:ndefcount))/max(small,real(ndefcount))
    finalc_aver         = sum(finalc        (1:ndefcount))/max(small,real(ndefcount))
    post_finalc_aver    = sum(post_finalc   (1:ndefcount))/max(small,real(ndefcount))

!25jul18
!Create averhairc(1:ndefcount-1)
! Define: hairc_aver, hairc_sd, corr_hairclength
    hairc_aver=sum(averhairc(1:ndefcount-1))/max(small,real(ndefcount-1))
    hairc_sd=sqrt(sum((averhairc(1:ndefcount-1)-hairc_aver) &
        &   *(averhairc(1:ndefcount-1)-hairc_aver))/max(small,real(ndefcount-1)))
    corr_hairclength=( sum(((averhairc(1:ndefcount-1))-hairc_aver) &
        &                *(lengthdef(1:ndefcount-1)-length_aver))/ &
            & max(small,real(ndefcount-1)))/(hairc_sd*length_sd)

    write(outfile1,*) 'aver length of episodes', length_aver
    write(outfile1,*) 'median length of episodes', length_median !12may18
    write(outfile1,*) 'sd of length', length_sd !14jun17
    write(outfile1,*) 'aver def during episodes', def_aver
    write(outfile1,*) 'corr def - length of episode', corr_dlength
    write(outfile1,*) 'corr spr - length of episode', corr_sprlength !14jun17
    write(outfile1,*) 'corr debt-to-Y - length of episode', corr_debttoylength !22jun17
    write(outfile1,*) 'corr logy - length of episode', corr_ylength !22jun17
    write(outfile1,*) 'corr hairc - length of episode', corr_hairclength !25jul18

    write(outfile1,*) !10jan19
    write(outfile1,*) 'pre_init   debt '  ,   pre_initdebttoy_aver   *100._prec
    write(outfile1,*) 'init       debt '  ,   initdebttoy_aver       *100._prec
    write(outfile1,*) 'mid        debt '  ,   middebttoy_aver        *100._prec
    write(outfile1,*) 'final      debt '  ,   finaldebttoy_aver      *100._prec
    write(outfile1,*) 'post_final debt '  ,   post_finaldebttoy_aver *100._prec
    write(outfile1,*)
    write(outfile1,*) 'pre_init   def '  ,   pre_initdef_aver        *100._prec
    write(outfile1,*) 'init       def '  ,   initdef_aver            *100._prec
    write(outfile1,*) 'mid        def '  ,   middef_aver             *100._prec
    write(outfile1,*) 'final      def '  ,   finaldef_aver           *100._prec
    write(outfile1,*) 'post_final def '  ,   post_finaldef_aver      *100._prec
    write(outfile1,*)
    write(outfile1,*) 'pre_init   spr '  ,   pre_initspr_aver        *100._prec
    write(outfile1,*) 'init       spr '  ,   initspr_aver            *100._prec
    write(outfile1,*) 'mid        spr '  ,   midspr_aver             *100._prec
    write(outfile1,*) 'final      spr '  ,   finalspr_aver           *100._prec
    write(outfile1,*) 'post_final spr '  ,   post_finalspr_aver      *100._prec
    write(outfile1,*)
    write(outfile1,*) 'pre_init   log y '  ,   pre_inity_aver        *100._prec
    write(outfile1,*) 'init       log y '  ,   inity_aver            *100._prec
    write(outfile1,*) 'mid        log y '  ,   midy_aver             *100._prec
    write(outfile1,*) 'final      log y '  ,   finaly_aver           *100._prec
    write(outfile1,*) 'post_final log y '  ,   post_finaly_aver      *100._prec
    write(outfile1,*)
    write(outfile1,*) 'pre_init   log c '  ,   pre_initc_aver        *100._prec
    write(outfile1,*) 'init       log c '  ,   initc_aver            *100._prec
    write(outfile1,*) 'mid        log c '  ,   midc_aver             *100._prec
    write(outfile1,*) 'final      log c '  ,   finalc_aver           *100._prec
    write(outfile1,*) 'post_final log c '  ,   post_finalc_aver      *100._prec

!    write(outfile1,*)
!    write(outfile1,*) ' Slope partdef on lenght ', beta(2)


! the other way
 x_mat(1:ndefcount,2)=averdef(1:ndefcount)
 y_mat(1:ndefcount)=real(lengthdef(1:ndefcount))
 call OLS(ndefcount,2,x_mat,y_mat,beta)
 write(outfile1,*)
 write(outfile1,*) ' Slope of length on partdef ', beta(2)

 deallocate(x_mat,y_mat)

! ---------------------------------------
! .. Spread on partial default ..
! ---------------------------------------

 allocate(x_mat(ntime,2),y_mat(ntime))
 x_mat(1:ntime,1)=one

! x_mat(1:ntime,2)=spread(1:ntime)
! y_mat(1:ntime)=partdef(1:ntime)
!
! call OLS(ntime,2,x_mat,y_mat,beta)
!
!   write(outfile1,*)
!    write(outfile1,*) ' Slope partdef on spread ', beta(2)

 ! the other way
    x_mat(1:ntime,2)=partdef(1:ntime)
    y_mat(1:ntime)=spread(1:ntime)
    call OLS(ntime,2,x_mat,y_mat,beta)
    write(outfile1,*) ' Slope of spread on partdef  ', beta(2)

 deallocate(x_mat,y_mat)

! ---------------------------------------
! .. Output on partial default ..
! ---------------------------------------
 allocate(x_mat(ntime,2),y_mat(ntime))
 x_mat(1:ntime,1)=one

! x_mat(1:ntime,2)=y(1:ntime)
! y_mat(1:ntime)=partdef(1:ntime)
!
! call OLS(ntime,2,x_mat,y_mat,beta)
!
!    write(outfile1,*)
!    write(outfile1,*) ' Slope partdef on output ', beta(2)

 ! the other way around
 x_mat(1:ntime,1)=one
 x_mat(1:ntime,2)=partdef(1:ntime)

 y_mat(1:ntime)=y(1:ntime)

 call OLS(ntime,2,x_mat,y_mat,beta)
 write(outfile1,*) ' Slope output on partdef  ', beta(2)

 deallocate(x_mat,y_mat)
! ---------------------------------------
! .. Debt on partial default ..
! ---------------------------------------
 allocate(x_mat(ntime,2),y_mat(ntime))
 x_mat(1:ntime,1)=one
 x_mat(1:ntime,1)=one
 x_mat(1:ntime,2)=partdef(1:ntime)

 y_mat(1:ntime)=a(1:ntime)/y(1:ntime)

 call OLS(ntime,2,x_mat,y_mat,beta)

 write(outfile1,*) ' Slope debt/Y on partdef  ', beta(2)

 deallocate(x_mat,y_mat)


!10feb21
    length_aver_stat         =       length_aver
    length_sd_stat           =       length_sd
    corr_dlength_stat        =       corr_dlength
    corr_hairclength_stat    =       corr_hairclength

    pre_initdebttoy_aver_stat    =   pre_initdebttoy_aver
    initdebttoy_aver_stat        =   initdebttoy_aver
    middebttoy_aver_stat         =   middebttoy_aver
    finaldebttoy_aver_stat       =   finaldebttoy_aver
    post_finaldebttoy_aver_stat  =   post_finaldebttoy_aver

    pre_initdef_stat   = pre_initdef_aver
    initdef_stat       = initdef_aver
    middef_stat        = middef_aver
    finaldef_stat      = finaldef_aver
    post_finaldef_stat = post_finaldef_aver
    pre_initspr_stat   = pre_initspr_aver
    initspr_stat       = initspr_aver
    midspr_stat        = midspr_aver
    finalspr_stat      = finalspr_aver
    post_finalspr_stat = post_finalspr_aver
    pre_inity_stat     = pre_inity_aver
    inity_stat         = inity_aver
    midy_stat          = midy_aver
    finaly_stat        = finaly_aver
    post_finaly_stat   = post_finaly_aver
    pre_initc_stat     = pre_initc_aver
    initc_stat         = initc_aver
    midc_stat          = midc_aver
    finalc_stat        = finalc_aver
    post_finalc_stat   = post_finalc_aver

! deallocate(lengthdef,averdef)
! deallocate(averspr)
! deallocate(averdebttoy,avery)
! deallocate(averhairc) !25jul18
! deallocate(initdebttoy, finaldebttoy, middebttoy) !10jan19
! deallocate(pre_initdebttoy, post_finaldebttoy) !09feb21
! deallocate(   &
!   &   pre_initdef     , &
!   &   initdef         , &
!   &   middef          , &
!   &   finaldef        , &
!   &   post_finaldef   , &
!   &   pre_initspr     , &
!   &   initspr         , &
!   &   midspr          , &
!   &   finalspr        , &
!   &   post_finalspr   , &
!   &   pre_inity       , &
!   &   inity           , &
!   &   midy            , &
!   &   finaly          , &
!   &   post_finaly     , &
!   &   pre_initc       , &
!   &   initc           , &
!   &   midc            , &
!   &   finalc          , &
!   &   post_finalc          )

end subroutine slope_coeffs

!-----------------------------------------------------------------------
SUBROUTINE OLS(n,k,x,y,beta)

!x is n x k
!y is n x 1
!beta is k x 1
IMPLICIT NONE
INTEGER, INTENT(in)		:: n,k
REAL(8), INTENT(in)		:: x(n,k),y(n)
REAL(8), INTENT(out)	:: beta(k)
REAL(8)					:: lxx(k,k),lxxinv(k,k)
INTEGER					:: ierr

lxx = matmul(transpose(x),x)
CALL InvertMatrix(lxx, lxxinv, k, ierr)
beta = matmul(lxxinv,matmul(transpose(x),y))

END SUBROUTINE OLS

!Subroutine to find the inverse of a square matrix
!Author : Louisda16th a.k.a Ashwith J. Rego
!Reference : Algorithm has been well explained in:
!http://math.uww.edu/~mcfarlat/inverse.htm
!http://www.tutor.ms.unimelb.edu.au/matrix/matrix_inverse.html
!-----------------------------------------------------------------------
SUBROUTINE InvertMatrix(matrix, inverse, n, errorflag)
	!USE Parameters	!added by Greg 2/28/11 so that Display can be used to control output of errors

	IMPLICIT NONE
	!Declarations
	INTEGER, INTENT(IN)  :: n
	INTEGER, INTENT(OUT) :: errorflag  !Return error status. -1 for error, 0 for normal
	REAL(8), INTENT(IN)	:: matrix(n,n)  !Input matrix
	REAL(8), INTENT(OUT)	:: inverse(n,n) !Inverted matrix
	
	LOGICAL :: FLAG = .TRUE.
	INTEGER :: i, j, k
	REAL(8) :: m
	REAL(8), DIMENSION(n,2*n) :: augmatrix !augmented matrix
	
	!Augment input matrix with an identity matrix
	DO i = 1, n
		DO j = 1, 2*n
			IF (j <= n ) THEN
				augmatrix(i,j) = matrix(i,j)
			ELSE IF ((i+n) == j) THEN
				augmatrix(i,j) = 1
			Else
				augmatrix(i,j) = 0
			ENDIF
		END DO
	END DO
	
	!Reduce augmented matrix to upper traingular form
	DO k =1, n-1
		IF (augmatrix(k,k) == 0) THEN
			FLAG = .FALSE.
			DO i = k+1, n
				IF (augmatrix(i,k) /= 0) THEN
					DO j = 1,2*n
						augmatrix(k,j) = augmatrix(k,j)+augmatrix(i,j)
					END DO
					FLAG = .TRUE.
					EXIT
				ENDIF
				IF (FLAG .EQV. .FALSE.) THEN
					!IF(Display>0) PRINT*, "Matrix is non - invertible"
					inverse = 0
					errorflag = -1
					return
				ENDIF
			END DO
		ENDIF
		DO j = k+1, n			
			m = augmatrix(j,k)/augmatrix(k,k)
			DO i = k, 2*n
				augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i)
			END DO
		END DO
	END DO
	
	!Test for invertibility
	DO i = 1, n
		IF (augmatrix(i,i) == 0) THEN
			!IF(Display>0) PRINT*, "Matrix is non - invertible"
			inverse = 0
			errorflag = -1
			return
		ENDIF
	END DO
	
	!Make diagonal elements as 1
	DO i = 1 , n
		m = augmatrix(i,i)
		DO j = i , (2 * n)				
			   augmatrix(i,j) = (augmatrix(i,j) / m)
		END DO
	END DO
	
	!Reduced right side half of augmented matrix to identity matrix
	DO k = n-1, 1, -1
		DO i =1, k
		m = augmatrix(i,k+1)
			DO j = k, (2*n)
				augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m
			END DO
		END DO
	END DO				
	
	!store answer
	DO i =1, n
		DO j = 1, n
			inverse(i,j) = augmatrix(i,j+n)
		END DO
	END DO
	errorflag = 0
END SUBROUTINE InvertMatrix


!------------------------------------------------------------------------------
subroutine split_by_default
use Percentile_mod
implicit none
integer :: j, jj, ndefgtzero
real(prec), dimension(2) :: pc, qdef
real(prec), allocatable :: partdef_gtzero(:)
real(prec), allocatable :: partdef1(:), partdef2(:), partdef3(:), partdef0(:)
real(prec), allocatable :: spread1(:), spread2(:), spread3(:), spread0(:)
real(prec), allocatable :: a1(:), a2(:), a3(:), a0(:)
real(prec), allocatable :: y1(:), y2(:), y3(:), y0(:)
integer :: j0, j1, j2, j3
real(prec), allocatable :: c1(:), c2(:), c3(:), c0(:)

    write(outfile1,*) ' ***********************************'
    write(outfile1,*) ' 25-75 PARTIAL DEF PERCENTILES '
    write(outfile1,*) ' ***********************************'

! .. Find percentile values ..

    ndefgtzero=count(partdef(1:ntime).gt.small)
    allocate(partdef_gtzero(ndefgtzero))

    print*,ndefgtzero
    jj=0
    do j=1, ntime
     if(partdef(j).gt.small) then
        jj=jj+1
        partdef_gtzero(jj)=partdef(j)
     end if
    end do
    print*, jj

    pc=(/.25_prec, .75_prec/)

    do  j=1,2
     call Percentile(ndefgtzero,partdef_gtzero,pc(j),qdef(j))
    end do

    write(outfile1,*) '25 and 75 percentiles '
    write(outfile1,*) 'pc', pc
    write(outfile1,*) 'qdef', qdef


! ..  Create subsamples ..

    allocate(partdef1(ndefgtzero), partdef2(ndefgtzero), partdef3(ndefgtzero))
    allocate(spread1(ndefgtzero), spread2(ndefgtzero), spread3(ndefgtzero))
    allocate(a1(ndefgtzero), a2(ndefgtzero), a3(ndefgtzero))
    allocate(y1(ndefgtzero), y2(ndefgtzero), y3(ndefgtzero))
    allocate(partdef0(ntime-ndefgtzero))
    allocate(spread0(ntime-ndefgtzero))
    allocate(a0(ntime-ndefgtzero))
    allocate(y0(ntime-ndefgtzero))

    allocate(c1(ndefgtzero), c2(ndefgtzero), c3(ndefgtzero))
    allocate(c0(ntime-ndefgtzero))

    ! .. subsample counters ..
    j0=0
    j1=0
    j2=0
    j3=0

    do j=1, ntime
     if((partdef(j).gt.small).and.(partdef(j).le.qdef(1))) then
        j1=j1+1
        y1(j1)=y(j)
        a1(j1)=a(j)
        spread1(j1)=spread(j)
        partdef1(j1)=partdef(j)
        c1(j1)=c(j)
     else if((partdef(j).gt.qdef(1)).and.(partdef(j).le.qdef(2))) then
        j2=j2+1
        y2(j2)=y(j)
        a2(j2)=a(j)
        spread2(j2)=spread(j)
        partdef2(j2)=partdef(j)
        c2(j2)=c(j)
     else if((partdef(j).gt.qdef(2))) then
        j3=j3+1
        y3(j3)=y(j)
        a3(j3)=a(j)
        spread3(j3)=spread(j)
        partdef3(j3)=partdef(j)
        c3(j3)=c(j)
     else if((partdef(j).le.small)) then
        j0=j0+1
        y0(j0)=y(j)
        a0(j0)=a(j)
        spread0(j0)=spread(j)
        partdef0(j0)=partdef(j)
        c0(j0)=c(j)
     end if
    end do

    ifsmalldef=0 !11may18
    write(outfile1,*)
    write(outfile1,*) ' Means 0 default '
    call report_means(j0,y0,a0,spread0,partdef0,c0)
    ifsmalldef=1 !11may18
    write(outfile1,*)
    write(outfile1,*) ' Means 0-25 quantile '
    call report_means(j1,y1,a1,spread1,partdef1,c1)
    ifsmalldef=0 !11may18
    write(outfile1,*)
    write(outfile1,*) ' Means 25-75 quantile '
    call report_means(j2,y2,a2,spread2,partdef2,c2)
    write(outfile1,*)
    write(outfile1,*) ' Means 75-100 quantile '
    call report_means(j3,y3,a3,spread3,partdef3,c3)

deallocate(partdef_gtzero,partdef1,partdef2,partdef3, partdef0)
deallocate(spread1,spread2,spread3,spread0)
deallocate(c1,c2,c3,c0)
deallocate(a1,a2,a3,a0)
deallocate(y1,y2,y3,y0)

end subroutine split_by_default
!------------------------------------------------------------------------------
 subroutine report_means(ntime,y,a,spread,partdef,c)
 implicit none
 integer :: ntime

! Local out: logy_diff, logz_diff, AtoY, DebttoY, freqdef,arrears, Spr
! Local dummy in: ntime, y,z,a,d, spread, partdef

real(prec), dimension(ntime) :: y,a,spread,partdef,c
real(prec):: logy_diff, AtoY, DebttoY, freqdef,arrears, Spr, logc_diff

 ! .. Statistics ..
    logy_diff=sum(log(y(1:ntime))-log(y_aver))/real(ntime)
!    logz_diff=sum(log(z(1:ntime))-z_aver)/real(ntime)
    AtoY=sum(a(1:ntime)/y(1:ntime))/real(ntime) !23jun17 (sum(a(1:ntime))/real(ntime))/(sum(y(1:ntime))/real(ntime))
    DebttoY=(sum(a(1:ntime)/y(1:ntime))/real(ntime))/((one-q0*delta)*modelfreq)
    freqdef=real(count(d(1:ntime).gt.zero+small))/real(ntime)
    arrears= sum(partdef(1:ntime))/real(ntime)
        ! sum(d(1:ntime)/a(1:ntime),d(1:ntime).gt.zero+small)/max(small,real(count(d(1:ntime).gt.zero+small)))
    Spr=sum(spread(1:ntime))/real(ntime)
    logc_diff=sum(log(c(1:ntime))-log(cons_aver))/real(ntime)

    write(outfile1,'(a30,f9.5)') 'dev log y from mean ', logy_diff
!    write(outfile1,'(a30,f9.5)') 'dev log z from mean ', logz_diff
    write(outfile1,'(a30,f9.5)') 'Debt due  to Y ', AtoY
    write(outfile1,'(a30,f9.5)') 'Total Debt to Y ', DebttoY
!    write(outfile1,'(a30,f9.5)') 'Frequency defau ', freqdef
    write(outfile1,'(a30,f9.5)') 'Partial default ', arrears
    write(outfile1,'(a30,f9.5)') 'Spread ', Spr
    write(outfile1,'(a30,f9.5)') 'Consumption ', logc_diff

    if(ifsmalldef.eq.1) smalldef=arrears !11may18

!    write(outfile1,'(4a6,a7,a2,6a8)')  'beta', 'jstar','phi1','gam','minPsi','¦', &
!                                      & 'A/Y', 'freqdef','arrears', 'spread','defsd', 'sprsd'
!    write(outfile1,'(f6.3,i6,f6.3,f6.3,f7.3,a2,6f8.4)') &
!                                    & beta, jzstar, phi1,gamma_psi, Psimin, &
!                                    & '¦', &
!                                    & AtoY, freqdef,  arrears, Spr, d_stdv, spr_stdv

 end subroutine report_means



!------------------------------------------------------------------------------
 subroutine annualdata
 implicit none
 integer :: time_yr
 integer :: ntime_yr
 real(prec), dimension(:), allocatable:: y_yr(:), z_yr(:),a_yr(:),b_yr(:), &
    &   d_yr(:), c_yr(:), spread_yr(:), partdef_yr(:), tb_yr(:)
 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/Replication/barg/simul/"
 ntime_yr=ntime/4
 allocate(y_yr(ntime_yr),z_yr(ntime_yr), &
    &     a_yr(ntime_yr),b_yr(ntime_yr), &
    &     d_yr(ntime_yr),c_yr(ntime_yr), &
    &     spread_yr(ntime_yr),partdef_yr(ntime_yr), &
    &     tb_yr(ntime_yr)   )

   time=1
   do time_yr=1, ntime_yr
    y_yr(time_yr)=sum(y(time:time+3)) !/4.0_prec
    z_yr(time_yr)=sum(z(time:time+3)) !/4.0_prec
    a_yr(time_yr)=sum(a(time:time+3)) !/4.0_prec
    b_yr(time_yr)=sum(b(time:time+3)) !/4.0_prec
    d_yr(time_yr)=sum(d(time:time+3)) !/4.0_prec
    c_yr(time_yr)=sum(c(time:time+3)) !/4.0_prec
    if(count(spread(time:time+3).lt.topcodedspr).ne.0) then
    spread_yr(time_yr)= &
     & sum(spread(time:time+3),spread(time:time+3).lt.topcodedspr) &
     & /real(count(spread(time:time+3).lt.topcodedspr))
    else
     spread_yr(time_yr)=topcodedspr
    end if
    !spread_yr(time_yr)=sum(spread(time:time+3))/4.0_prec
    if(a_yr(time_yr).gt.zero) then  !07mar16
     partdef_yr(time_yr)=d_yr(time_yr)/a_yr(time_yr)
    else
     partdef_yr(time_yr)=d_yr(time_yr) !04apr19: to get above small
    end if
    tb_yr(time_yr)=sum(tb(time:time+3)) !/4.0_prec
    time=time+4
   end do



    ntime=ntime_yr
    y(1:ntime)=y_yr(1:ntime)
    z(1:ntime)=z_yr(1:ntime)
    a(1:ntime)=a_yr(1:ntime)
    b(1:ntime)=b_yr(1:ntime)
    d(1:ntime)=d_yr(1:ntime)
    c(1:ntime)=c_yr(1:ntime)
    spread(1:ntime)=spread_yr(1:ntime)
    partdef(1:ntime)=partdef_yr(1:ntime)
    tb(1:ntime)=tb_yr(1:ntime)

!11apr18  IF(ID==0) THEN !10jan18
  open (42, file=fileplace//'simulpaths_yr.dat')
    write(42,*) 'time, y,  z, a, b, d, c, spr '
    do time=1, min(5000,ntime) !18feb17
    if((time.ge.2000).and.(time.le.ntime)) write(42, & !13dec15
                    & '(i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6,f30.12)') &
        & time, y(time),  z(time), a(time),  &
        & b(time), d(time), &
        & c(time), spread(time)                 !09jan14
    end do
  close(42)
!11apr18  END IF

!!*    open(297, file='inc_t.dat')
!!*     do time=1, ntime
!!*        write(297,'(i6,f14.6,f14.6,i4)') time, inc_t(time), ui_t(time), emp_t(time)
!!*     end do
!!*    close(297)


 end subroutine annualdata
!------------------------------------------------------------------------------
subroutine final_stats
implicit none

!open(47, file='final_stats.dat') !10feb21
!write(47,*) 'QUARTERLY DATA'
! [report_stats]
    write(47,'(a25,f9.4)') 'Sd log inc ', sqrt(logy_var)
    write(47,'(a25,f9.4)') 'Autocorr log inc ', logy_corr !26may15


   write(47,'(a30,a10,f9.5)') 'partial default', '(D/A)', arrears
   write(47,'(a30,a10,f9.5)') 'freq arrears>0', '  ', freqdef
   write(47,'(a30,a10,f9.5)') 'debt due/output', 'A/Y', (sum(a(1:ntime)/y(1:ntime))/real(ntime))
   write(47,'(a30,a10,f9.5)') 'spread ', ' ', sum(spread(1:ntime), &
    &   spread(1:ntime).lt.topcodedspr)/count(spread(1:ntime).lt.topcodedspr)
   write(47,'(a30,a10,f9.5)') 'debt/output' , ' ', &      !16jan15
                & (sum(a(1:ntime)/y(1:ntime)) &
                &       /real(ntime))/((one-q0*delta)*modelfreq) !23jun17


   ! location sensitive
   write(47,*)
   write(47,'(a30,a10,f9.5)') 'sd spread', '  ',    spr_stdv
   write(47,'(a30,a10,f9.5)') 'sd part default', '  ',    d_stdv !d_stdv_noncond
   write(47,'(a30,a10,f9.5)') 'sd debt /output', '  ',    &
    & debtdue_stdv/((one-q0*delta)*modelfreq)
   write(47,'(a30,a10,f9.5)') 'sd debtdue /output', '  ',  debtdue_stdv
   write(47,'(a30,a10,f9.5)') 'corr y spread', '  ',          corrSpr
   write(outfile1,'(a30,a10,f9.5)') 'corr spread debttoY', '  ', &
        & ( sum(((spread(1:ntime))-spr_aver)*((a(1:ntime)/y(1:ntime))-debtdue), &
        &   (spread(1:ntime).lt.topcodedspr))/ &
        &   real(count(spread(1:ntime).lt.topcodedspr)) )/(spr_stdv*debtdue_stdv)


   write(47,'(a30,a10,f9.5)') 'corr partdefault spread', '  ',   corr_dspr
   write(47,'(a30,a10,f9.5)') 'corr partdefault logy', '  ',   corr_dy
   write(47,'(a30,a10,f9.5)') 'corr partdefault debttoY', '  ',   corr_ddebttoY

   write(47,*)
   write(47,'(a30,a10,f9.5)') 'coupon def/Y |def>0', '  ', coupdef_cond
   write(47,'(a30,a10,f9.5)') 'sd coupon def/Y |def>0', '  ', coupdef_cond_sd
   write(47,'(a30,a10,f9.5)') 'coupon def/Y', '  ', coupdef
   write(47,'(a30,a10,f9.5)') 'sd coupon def/Y', '  ', coupdef_sd
   write(47,'(a30,a10,f9.5)') 'debt service', '  ', debtserv
   write(47,'(a30,a10,f9.5)') 'sd debt service', '  ', debtserv_sd

! [haircuts_extensions]
   write(47,*)
    write(47,'(a25,f9.4)') 'haircut',  haircut_stat
    write(47,'(a25,f9.4)') 'extension', extension_stat


! [slope_coeff]

    write(47,'(a25,f9.4)') 'aver length of episodes', length_aver_stat
    write(47,'(a25,f9.4)') 'sd of length', length_sd_stat
    write(47,'(a25,f9.4)') 'corr def - length of episode', corr_dlength_stat
    write(47,'(a25,f9.4)') 'corr hairc - length of episode', corr_hairclength_stat
    write(47,*)
    write(47,'(a25,f9.4)') 'pre_init debt ', pre_initdebttoy_aver_stat
    write(47,'(a25,f9.4)') 'init debt ', initdebttoy_aver_stat
    write(47,'(a25,f9.4)') 'mid debt ',  middebttoy_aver_stat
    write(47,'(a25,f9.4)') 'final debt ', finaldebttoy_aver_stat
    write(47,'(a25,f9.4)') 'post_final debt ', post_finaldebttoy_aver_stat
    write(47,*)
    write(47,'(a25,f9.4)')  ' pre_initdef_stat  ',       pre_initdef_stat
    write(47,'(a25,f9.4)')  ' initdef_stat      ',       initdef_stat
    write(47,'(a25,f9.4)')  ' middef_stat       ',       middef_stat
    write(47,'(a25,f9.4)')  ' finaldef_stat     ',       finaldef_stat
    write(47,'(a25,f9.4)')  ' post_finaldef_stat',       post_finaldef_stat
    write(47,*)
    write(47,'(a25,f9.4)')  ' pre_initspr_stat  ',       pre_initspr_stat
    write(47,'(a25,f9.4)')  ' initspr_stat      ',       initspr_stat
    write(47,'(a25,f9.4)')  ' midspr_stat       ',       midspr_stat
    write(47,'(a25,f9.4)')  ' finalspr_stat     ',       finalspr_stat
    write(47,'(a25,f9.4)')  ' post_finalspr_stat',       post_finalspr_stat
    write(47,*)
    write(47,'(a25,f9.4)')  ' pre_inity_stat    ',       pre_inity_stat
    write(47,'(a25,f9.4)')  ' inity_stat        ',       inity_stat
    write(47,'(a25,f9.4)')  ' midy_stat         ',       midy_stat
    write(47,'(a25,f9.4)')  ' finaly_stat       ',       finaly_stat
    write(47,'(a25,f9.4)')  ' post_finaly_stat  ',       post_finaly_stat
    write(47,*)
    write(47,'(a25,f9.4)')  ' pre_initc_stat    ',       pre_initc_stat
    write(47,'(a25,f9.4)')  ' initc_stat        ',       initc_stat
    write(47,'(a25,f9.4)')  ' midc_stat         ',       midc_stat
    write(47,'(a25,f9.4)')  ' finalc_stat       ',       finalc_stat
    write(47,'(a25,f9.4)')  ' post_finalc_stat  ',       post_finalc_stat

! [split_by_default]
    write(47,*)
    write(47,'(a25,f9.4)') 'small def  ',  smalldef

!close(47)

end subroutine final_stats

 end subroutine simul_paths

! *************************************************************
! IRF
! *************************************************************
 subroutine stochsimul_IRF(ntime,npaths)
 !20apr17 - changes to time-loop for IRF's
 use interp
 implicit none

!20apr17
 integer :: ntime, npaths
 integer :: time, pathindex
 integer :: count_seed
 real(prec) :: pc_z
 real(prec), dimension(:), allocatable :: z_aver(:),a_aver(:), &
        &  y_aver(:),b_aver(:),d_aver(:),c_aver(:),spread_aver(:)
 CHARACTER(*), PARAMETER :: fileplace = "/data/home/tew158/partdef/Replication/barg/IRF/"



 real(prec) :: x_z, x_nu, x_d, defaux, qqqtil, parsum
 real(prec) :: vtemp_ND, vtemp_D
 integer :: jalow, jaup
 integer :: jz, jtheta, jnu, jzpr, jthetapr, jnupr, d01
 real(prec) :: atarget

 integer, parameter:: nshocks=3
 real(prec), dimension(:), allocatable:: ran_out
 integer, dimension(:), allocatable:: seed

 real(prec), dimension(:), allocatable :: a, z, tau, b, d, partdef, q, spread, y, c, tb
 integer, dimension(:), allocatable :: theta, nu

 real(prec) :: topcodedspr


!20apr17
 allocate (z_aver(ntime),a_aver(ntime),y_aver(ntime),b_aver(ntime), &
        &   d_aver(ntime),c_aver(ntime),spread_aver(ntime))



 allocate (ran_out(nshocks))
 allocate (seed(nshocks))
 allocate (z(ntime),a(ntime),y(ntime),b(ntime),tau(ntime),d(ntime),c(ntime),q(ntime), &
    &   tb(ntime),spread(ntime), partdef(ntime), theta(ntime), nu(ntime))




!20apr17
    open(297, file=fileplace//'simulIRFparam.dat')
    write(297,'(a14,a14,a14,a14)') 'delta', 'q0', 'freq', 'zaver_glob'
    write(297,'(f14.6,f14.6,f14.6,f14.6)') delta, q0, modelfreq, zaver_glob
    close(297)
!20apr17
    if(doIRF.eq.4)  then
     if(dropjz_IRF.eq.1) then
        open (42, file=fileplace//'stochsimulIRF_zandy.dat')
     else if(dropjz_IRF.eq.2) then
        open (42, file=fileplace//'stochsimulIRF_zandy_2j.dat')
     else
        open (42, file=fileplace//'stochsimulIRF_zandy.dat')
     end if
    end if
    write(42,*) ' --------------------'
    write(42,*) ' PATHS '
    write(42,*) ' --------------------'
    write(42,*) 'time, y,  z, a, b, d, c, spr '
        y_aver(:)=zero
        z_aver(:)=zero
        a_aver(:)=zero
        b_aver(:)=zero
        d_aver(:)=zero
        c_aver(:)=zero
        spread_aver(:)=zero

 !
 ! .. Path loop ..
 !
 do pathindex=1, npaths
 write(defout,*) ' path number ', pathindex


! Initialise states

    jz=int(nz/2)
    atarget=a_aver2/modelfreq
    jtheta=0
    jnu=1

! Seeds

    CALL SYSTEM_CLOCK( count_seed )

    seed(1) = count_seed
    seed(2) = count_seed+1
    seed(3) = count_seed+2

    CALL random_seed(put=seed(1:nshocks))

 !
 ! .. Time loop ..
 !
 do time=1, ntime
    !
    ! [0] States
    !
        z(time)=zj(jz)
        a(time)=atarget
        theta(time)=jtheta
        nu(time)=jnu

    !
    ! [1] Exogenous stochastic shocks
    !
        call random_number(ran_out(1:nshocks))
        x_z=ran_out(1)
        x_nu=ran_out(2)
        x_d=ran_out(3)

    !
    ! [2] Current d01 and total default d
    !

    if(jtheta.eq.0) then
        if(x_d.eq.one) then
         d01=0
        else if(x_d.eq.zero) then
         d01=1
        else
         defaux=lip(Aj,DEF(:,jtheta,jz,jnu),a(time))
         if (x_d.le.defaux) then
            d01=1
         else
            d01=0
         end if
        end if
    end if

if((barg_option.eq.0).or.(barg_option.eq.2)) then
    if(jtheta.eq.1) then
        !!tau(time)=lip(Aj,TT(:,jtheta,jz,jnu,d01),a(time))
        jalow=count(Aj.le.a(time))
        jaup=min(jalow+1,nA)

        if(DEF(jalow,jtheta,jz,jnu).gt.one-small) then        !when def is 0 or 1 for sure
            d01=1 !lip(Aj,DEF(:,jtheta,jz,jnu),a(time))
        else if(DEF(jaup,jtheta,jz,jnu).lt.zero+small) then
            d01=0 !lip(Aj,DEF(:,jtheta,jz,jnu),a(time))

        else if( &                                            !if DEF interior (0,1)
            &   (DEF(jalow,jtheta,jz,jnu).gt.zero+small) &
            &   .or.    &
            &   (DEF(jaup,jtheta,jz,jnu).lt.one-small) ) then
                if(x_d.eq.one) then
                    d01=0
                else if(x_d.eq.zero) then
                    d01=1
                else
                defaux=lip(Aj,DEF(:,jtheta,jz,jnu),a(time))
                    if (x_d.le.defaux) then
                        d01=1
                    else
                        d01=0
                    end if
                end if
        else                                            ! if def either 0 or 1, not for sure which
            if(jnu.eq.1) then
                vtemp_ND=lip(Aj,vB_ND(:,jz),a(time))
                vtemp_D=lip(Aj,vB_D(:,jz),a(time))
            end if
            if(jnu.eq.2) then
                vtemp_ND=lip(Aj,wB_ND(:,jz),a(time))
                vtemp_D=lip(Aj,wB_D(:,jz),a(time))
            end if
            if ( vtemp_ND.ge.vtemp_D) then
                d01=0
            else
                d01=1
            end if

        end if
    end if
end if

    tau(time)=lip(Aj,TT(:,jtheta,jz,jnu,d01),a(time))
    d(time)=a(time)-tau(time)

    jthetapr=d01

    !
    ! [3] endogenous decision and prices
    !
        if((jtheta.eq.0).and.(d01.eq.0)) then
         b(time)=lip(Aj,BND_c(:,jz,jnu),a(time))
        else
         b(time)=zero
        end if

        if(a(time).gt.zero) then
            partdef(time)=d(time)/a(time)
        else
            partdef(time)=zero
        end if

        if(theta(time).eq.1) then
         qqqtil=zero !12aug21 qqtil=zero
        else
         qqqtil=blip(Bj,Aj,qq(:,:,jthetapr,jz,jnu),b(time),a(time))
        end if
        q(time)=qqqtil

         if(qqqtil.le.small) then
            spread(time)= topcodedspr
         else
            spread(time)= (((one/qqqtil)+delta)**modelfreq)  &
            &       -((one/q0)**modelfreq)
         end if

        y(time)=zj(jz)*psi(jtheta,jz)
        c(time)=y(time)-tau(time)+qqqtil*b(time)
        tb(time)=y(time)-c(time)

        !20apr17
        ! .. cumulative values over paths ..
        y_aver(time)=y_aver(time)+y(time)
        z_aver(time)=z_aver(time)+z(time)
        a_aver(time)=a_aver(time)+a(time)
        b_aver(time)=b_aver(time)+b(time)
        d_aver(time)=d_aver(time)+d(time)
        c_aver(time)=c_aver(time)+c(time)
        spread_aver(time)=spread_aver(time)+spread(time)


    !
    ! [4] Next-period states
    !
        atarget=lip(Aj,AA(:,jtheta,jz,jnu,d01),a(time))
        jtheta=jthetapr

        if(x_z.eq.one) then
            jzpr=nz
        else if(x_z.eq.zero) then
            jzpr=1
        else
        parsum=zero
            do jzpr=1, nz
             if((x_z.ge.parsum).and.(x_z.lt.parsum+piz(jz,jzpr)))  exit
             parsum=parsum+piz(jz,jzpr)
            end do
        end if
        jz=jzpr

        if(x_nu.eq.one) then
            jnupr=nnu
        else if(x_nu.eq.zero) then
            jnupr=1
        else
        parsum=zero
            do jnupr=1, nnu
             if((x_nu.ge.parsum).and.(x_nu.lt.parsum+pinu(jnu,jnupr)))  exit
             parsum=parsum+pinu(jnu,jnupr)
            end do
        end if
        jnu=jnupr

    !20apr17
    if( (time.eq.int(ntime/2)).and.(doIRF.eq.4) ) then
        pc_z=zj(min(max(jz-dropjz_IRF,1),nz))/zj(jz)
        jz=max(jz-dropjz_IRF,1)
    end if

 end do !time

 end do !pathindex loop

!20jun17
        y_aver(:)=y_aver(:)/real(npaths)
        z_aver(:)=z_aver(:)/real(npaths)
        a_aver(:)=a_aver(:)/real(npaths)
        b_aver(:)=b_aver(:)/real(npaths)
        d_aver(:)=d_aver(:)/real(npaths)
        c_aver(:)=c_aver(:)/real(npaths)
        spread_aver(:)=spread_aver(:)/real(npaths)
        do time=1, ntime
        write(42,'( &
                    & i6,f10.6,f10.6,f10.6, &
                    & f10.6,f10.6, &
                    & f10.6,f10.6)') &
            & time, y_aver(time),  z_aver(time), a_aver(time),  &
            & b_aver(time), d_aver(time), &
            & c_aver(time), spread_aver(time)
        end do

    deallocate(ran_out,seed)
    deallocate(z,a,y,b,d,c,q,tb,spread,partdef,theta,nu)
    deallocate(z_aver,a_aver,y_aver,b_aver,d_aver,c_aver,spread_aver)

close(42)


 end subroutine stochsimul_IRF
!***************************************************************************
!15jul21
 subroutine calib_bobyqa_case1
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case1.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=2
    mv=2
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec !0.20_prec !0.2_prec !0.5_prec !0.40_prec
    rhoend= 0.01_prec  !0.0010_prec !0.0001_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    !DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    !freqdef_dat=    0.340_prec
    !arrears_dat=    0.340_prec
    !debtstdv_dat=   0.180_prec
    !dstdv_dat=      0.160_prec
    sprstdv_dat=    0.041_prec
    !logy_sd_dat=    0.100_prec  !0.075616365_prec (qrt)


 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	!phi1=0.119_prec
	Psimin=0.85_prec
	beta=0.93_prec

 !
 ! .. bounds ..
 !
     !phi1_l=phi1*.70_prec
     !phi1_h=phi1*1.30_prec
	 Psimin_l=Psimin*.90_prec
     Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,'(a15,f20.16)') 'phi1= ' , phi1
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu(1,1)

    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') ' DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    !write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    !write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    !write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    !write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    !write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    !write(44,'(a15,f10.6)') 'phi1     ',   phi1
    !write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    !write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
     !param(1)=(phi1-phi1_l)/(phi1_h-phi1_l)
     !param(2)=(gamma_psi-gamma_l)/(gamma_h-gamma_l)
     param(1)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(2)=(beta-beta_l)/(beta_h-beta_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(8a9,5a9,a9)') 'Psimin', 'phi1',  'beta ',  &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: Psimin, beta ', &
        &   (Psimin_h-Psimin_l)*param(1)+Psimin_l, & !13jan15
        &   (beta_h-beta_l)*param(2)+beta_l
!    write(44,*) 'param: phi, gam, Psimin, beta, Rbar, sdeta ', &
!        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
!        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
!        &   (beta_h-beta_l)*param(4)+beta_l, &
!        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
!        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ', Psimin, beta
    !write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta

 end subroutine calib_bobyqa_case1
! **************************************************************
!15jul21
 subroutine calib_bobyqa_case2
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case2.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=4
    mv=6
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec
    rhoend= 0.01_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    !DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    sprstdv_dat=    0.041_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec


 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	pinu1=0.75_prec !0.50_prec
    phi1=0.1191278_prec
	Psimin=0.90_prec !0.85_prec
	beta=0.93_prec

 !
 ! .. bounds ..
 !

     pinu1_l=0.51_prec !0.20_prec !0.10_prec
     pinu1_h=0.99_prec !0.50_prec !0.90_prec
     phi1_l=phi1*.70_prec
     phi1_h=phi1*1.30_prec
	 Psimin_l=Psimin*.90_prec
     Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN MAIN CODE'
    write(44,*) '--------------------------------'
    write(44,*) 'no smoothing at all - smoothing with factor_reduc=4'
    write(44,*) 'activated new barg fixes in !14aug21 !16aug21 !17aug21 '
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN INPUT FILE'
    write(44,*) '--------------------------------'
    write(44,'(a15,i12)') 'calibrcase= ', calibrcase
    write(44,'(a15,i12)') 'niter= ', niter
    write(44,'(a15,i12)') 'finiteec= ', finiteec
    write(44,'(a15,f12.9)') 'speed_adjh1= ', speed_adjh1
    write(44,'(a15,f12.9)') 'speed_adjh2= ', speed_adjh2
    write(44,'(a25,i12)') 'iter_switch_speedh= ', iter_switch_speedh
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta

    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') 'DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    !write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    !write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f20.16)') 'phi1= ' , phi1
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu1

    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'pinu1     ',   pinu1_l  ,  pinu1_h
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h

    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
     param(1)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(2)=(beta-beta_l)/(beta_h-beta_l)
     param(3)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(4)=(pinu1-pinu1_l)/(pinu1_h-pinu1_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(9a9,5a9,a9)') 'pinu1', 'Psimin', 'phi1',  'beta ',  &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: Psimin, beta, phi1, pinu1 ', &
        &   (Psimin_h-Psimin_l)*param(1)+Psimin_l, &
        &   (beta_h-beta_l)*param(2)+beta_l, &
        &   (phi1_h-phi1_l)*param(3)+phi1_l, &
        &   (pinu1_h-pinu1_l)*param(4)+pinu1_l
!    write(44,*) 'param: phi, gam, Psimin, beta, Rbar, sdeta ', &
!        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
!        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
!        &   (beta_h-beta_l)*param(4)+beta_l, &
!        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
!        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ', Psimin, beta, phi1, pinu1
    !write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta

 end subroutine calib_bobyqa_case2
!+++! **************************************************************
!15jul21
 subroutine calib_bobyqa_case3
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case3.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=3
    mv=3
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec
    rhoend= 0.01_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    AtoY_dat=       0.050_prec
    sprstdv_dat=    0.041_prec
    hhaircut_dat=   0.360_prec


 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	pinu1=0.50_prec
	Psimin=0.85_prec
	beta=0.93_prec

 !
 ! .. bounds ..
 !

     pinu1_l=0.10_prec
     pinu1_h=0.90_prec
	 Psimin_l=Psimin*.90_prec
     Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,'(a15,f20.16)') 'phi1= ' , phi1

    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') 'DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' hhaircut_dat  ',   hhaircut_dat

    !write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu1

    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'pinu1     ',   pinu1_l  ,  pinu1_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h

    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
     param(1)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(2)=(beta-beta_l)/(beta_h-beta_l)
     param(3)=(pinu1-pinu1_l)/(pinu1_h-pinu1_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(9a9,5a9,a9)') 'pinu1', 'Psimin', 'phi1',  'beta ',  &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: Psimin, beta, pinu1 ', &
        &   (Psimin_h-Psimin_l)*param(1)+Psimin_l, &
        &   (beta_h-beta_l)*param(2)+beta_l, &
        &   (pinu1_h-pinu1_l)*param(3)+pinu1_l

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ', Psimin, beta, pinu1


 end subroutine calib_bobyqa_case3

! **************************************************************
 subroutine calib_bobyqa_case4
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case4.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=3
    mv=3
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec
    rhoend= 0.01_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    !DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    sprstdv_dat=    0.041_prec
    debtstdv_dat=   0.180_prec
    !dstdv_dat=      0.160_prec
    !freqdef_dat=    0.340_prec
    !arrears_dat=    0.340_prec


 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	pinu1=0.75_prec !0.50_prec
    !phi1=0.1191278_prec
	Psimin=0.90_prec !0.85_prec
	beta=0.93_prec

 !
 ! .. bounds ..
 !

     pinu1_l=0.51_prec !0.10_prec
     pinu1_h=0.99_prec !0.90_prec
	 Psimin_l=Psimin*.90_prec
     Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN MAIN CODE'
    write(44,*) '--------------------------------'
    write(44,*) 'no smoothing at all - smoothing with factor_reduc=4'
    write(44,*) 'activated new barg fixes in !14aug21 !16aug21 !17aug21 '
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN INPUT FILE'
    write(44,*) '--------------------------------'
    write(44,'(a15,i12)') 'calibrcase= ', calibrcase
    write(44,'(a15,i12)') 'niter= ', niter
    write(44,'(a15,i12)') 'finiteec= ', finiteec
    write(44,'(a15,f12.9)') 'speed_adjh1= ', speed_adjh1
    write(44,'(a15,f12.9)') 'speed_adjh2= ', speed_adjh2
    write(44,'(a25,i12)') 'iter_switch_speedh= ', iter_switch_speedh
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION PARAM SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,'(a15,f20.16)') 'phi1= ' , phi1

    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') 'DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    !write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu1

    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'pinu1     ',   pinu1_l  ,  pinu1_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h

    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
     param(1)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(2)=(beta-beta_l)/(beta_h-beta_l)
     param(3)=(pinu1-pinu1_l)/(pinu1_h-pinu1_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(9a9,5a9,a9)') 'pinu1', 'Psimin', 'phi1',  'beta ',  &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: Psimin, beta, pinu1 ', &
        &   (Psimin_h-Psimin_l)*param(1)+Psimin_l, &
        &   (beta_h-beta_l)*param(2)+beta_l, &
        &   (pinu1_h-pinu1_l)*param(3)+pinu1_l
!    write(44,*) 'param: phi, gam, Psimin, beta, Rbar, sdeta ', &
!        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
!        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
!        &   (beta_h-beta_l)*param(4)+beta_l, &
!        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
!        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ', Psimin, beta, pinu1
    !write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta

 end subroutine calib_bobyqa_case4
! **************************************************************
 subroutine calib_bobyqa_case5
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case5.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=4
    mv=4
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec
    rhoend= 0.01_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    !DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    sprstdv_dat=    0.041_prec
    debtstdv_dat=   0.180_prec
    hhaircut_dat=   0.360_prec
    !dstdv_dat=      0.160_prec
    !freqdef_dat=    0.340_prec
    !arrears_dat=    0.340_prec


 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	pinu1=0.60_prec !0.75_prec !0.50_prec
    phi1=0.1191278_prec
	Psimin=0.90_prec !0.85_prec
	beta=0.93_prec

 !
 ! .. bounds ..
 !

     pinu1_l=0.35_prec !0.51_prec !0.10_prec
     pinu1_h=0.85_prec !0.99_prec !0.90_prec
     phi1_l=phi1*.70_prec
     phi1_h=phi1*1.30_prec
     Psimin_l=Psimin*.90_prec
     Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN MAIN CODE'
    write(44,*) '--------------------------------'
    write(44,*) 'no smoothing at all - smoothing with factor_reduc=4'
    write(44,*) 'activated new barg fixes in !14aug21 !16aug21 !17aug21 '
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN INPUT FILE'
    write(44,*) '--------------------------------'
    write(44,'(a15,i12)') 'calibrcase= ', calibrcase
    write(44,'(a15,i12)') 'niter= ', niter
    write(44,'(a15,i12)') 'finiteec= ', finiteec
    write(44,'(a15,f12.9)') 'speed_adjh1= ', speed_adjh1
    write(44,'(a15,f12.9)') 'speed_adjh2= ', speed_adjh2
    write(44,'(a25,i12)') 'iter_switch_speedh= ', iter_switch_speedh
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION PARAM SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    !write(44,'(a15,f20.16)') 'phi1= ' , phi1

    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') 'DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' hhaircut_dat  ',   hhaircut_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu1
    write(44,'(a15,f20.16)') 'phi1= ' , phi1
    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,'(a15,2f10.6)') 'pinu1     ',   pinu1_l  ,  pinu1_h
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
     param(1)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(2)=(beta-beta_l)/(beta_h-beta_l)
     param(3)=(pinu1-pinu1_l)/(pinu1_h-pinu1_l)
     param(4)=(phi1-phi1_l)/(phi1_h-phi1_l)


     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(9a9,5a9,a9)') 'pinu1', 'Psimin', 'phi1',  'beta ',  &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: Psimin, beta, pinu1, phi1 ', &
        &   (Psimin_h-Psimin_l)*param(1)+Psimin_l, &
        &   (beta_h-beta_l)*param(2)+beta_l, &
        &   (pinu1_h-pinu1_l)*param(3)+pinu1_l, &
        &   (phi1_h-phi1_l)*param(4)+phi1_l
!    write(44,*) 'param: phi, gam, Psimin, beta, Rbar, sdeta ', &
!        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
!        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
!        &   (beta_h-beta_l)*param(4)+beta_l, &
!        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
!        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ', Psimin, beta, pinu1, phi1
    !write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta

 end subroutine calib_bobyqa_case5

! **************************************************************
 subroutine calib_bobyqa_case6
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case6.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=4
    mv=8
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec
    rhoend= 0.01_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    !DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    sprstdv_dat=    0.041_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtserv_dat=    0.036_prec
    debtserv_sd_dat= 0.021_prec

 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	pinu1=0.60_prec !0.75_prec !0.50_prec
    phi1=0.1191278_prec
	Psimin=0.90_prec !0.85_prec
	beta=0.93_prec

 !
 ! .. bounds ..
 !

     pinu1_l=0.51_prec !0.20_prec !0.10_prec
     pinu1_h=0.99_prec !0.50_prec !0.90_prec
     pinu1_l=0.35_prec
     pinu1_h=0.85_prec

     phi1_l=phi1*.70_prec
     phi1_h=phi1*1.30_prec
	 Psimin_l=Psimin*.90_prec
     Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN MAIN CODE'
    write(44,*) '--------------------------------'
    write(44,*) 'no smoothing at all - smoothing with factor_reduc=4'
    write(44,*) 'activated new barg fixes in !14aug21 !16aug21 !17aug21 '
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN INPUT FILE'
    write(44,*) '--------------------------------'
    write(44,'(a15,i12)') 'calibrcase= ', calibrcase
    write(44,'(a15,i12)') 'niter= ', niter
    write(44,'(a15,i12)') 'finiteec= ', finiteec
    write(44,'(a15,f12.9)') 'speed_adjh1= ', speed_adjh1
    write(44,'(a15,f12.9)') 'speed_adjh2= ', speed_adjh2
    write(44,'(a25,i12)') 'iter_switch_speedh= ', iter_switch_speedh
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta

    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') 'DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    !write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,'(a15,f10.6)') ' debtserv_dat ', debtserv_dat
    write(44,'(a15,f10.6)') ' debtserv_sd_dat ', debtserv_sd_dat

    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    !write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f20.16)') 'phi1= ' , phi1
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu1

    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'pinu1     ',   pinu1_l  ,  pinu1_h
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h

    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
     param(1)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(2)=(beta-beta_l)/(beta_h-beta_l)
     param(3)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(4)=(pinu1-pinu1_l)/(pinu1_h-pinu1_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(9a9,5a9,a9,a7,a7)') 'pinu1', 'Psimin', 'phi1',  'beta ',  &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc', &
            & 'serv', 'servsd'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: Psimin, beta, phi1, pinu1 ', &
        &   (Psimin_h-Psimin_l)*param(1)+Psimin_l, &
        &   (beta_h-beta_l)*param(2)+beta_l, &
        &   (phi1_h-phi1_l)*param(3)+phi1_l, &
        &   (pinu1_h-pinu1_l)*param(4)+pinu1_l
!    write(44,*) 'param: phi, gam, Psimin, beta, Rbar, sdeta ', &
!        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
!        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
!        &   (beta_h-beta_l)*param(4)+beta_l, &
!        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
!        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ', Psimin, beta, phi1, pinu1
    !write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta

 end subroutine calib_bobyqa_case6
! **************************************************************
 subroutine calib_bobyqa_case7
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case7.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=4
    mv=9
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec
    rhoend= 0.01_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    !DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    sprstdv_dat=    0.041_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtserv_dat=    0.036_prec
    debtserv_sd_dat= 0.021_prec
    hhaircut_dat=   0.360_prec

!
! .. calibration weights ..
!
    calibw_AtoY     =3.0_prec
    calibw_sprsd    =1.25_prec  !4.0_prec
    calibw_hairc    =3.0_prec
    calibw_freq     =1.0_prec
    calibw_def      =1.0_prec
    calibw_dsd      =1.0_prec


 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	pinu1=0.474619477941049_prec !0.589607247340112_prec !0.557303010024696_prec !0.60_prec !0.75_prec !0.50_prec
    phi1=0.145546986392327 !0.52_prec !0.144353760214413_prec !0.151867516444439_prec !0.1191278_prec
	Psimin= 0.893885437683567 !0.90_prec !0.896599199369401_prec !0.892383007777493_prec !0.90_prec !0.85_prec
	beta=0.933744088519083 !0.930643558122177_prec !0.948151331675872_prec !0.93_prec

 !
 ! .. bounds ..
 !

     pinu1_l=0.51_prec !0.20_prec !0.10_prec
     pinu1_h=0.99_prec !0.50_prec !0.90_prec
     pinu1_l=0.30_prec
     pinu1_h=0.90_prec
     pinu1_l=pinu1*0.80_prec !0.30_prec
     pinu1_h=pinu1*1.20_prec !0.90_prec


     phi1_l=phi1*0.60_prec !phi1*.70_prec
     phi1_h=phi1*1.40_prec !phi1*1.30_prec
	 Psimin_l=Psimin*.90_prec
     Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN MAIN CODE'
    write(44,*) '--------------------------------'
    write(44,*) 'no smoothing at all - smoothing with factor_reduc=4'
    write(44,*) 'activated new barg fixes in !14aug21 !16aug21 !17aug21 '
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN INPUT FILE'
    write(44,*) '--------------------------------'
    write(44,'(a15,i12)') 'calibrcase= ', calibrcase
    write(44,'(a15,i12)') 'niter= ', niter
    write(44,'(a15,i12)') 'finiteec= ', finiteec
    write(44,'(a15,f12.9)') 'speed_adjh1= ', speed_adjh1
    write(44,'(a15,f12.9)') 'speed_adjh2= ', speed_adjh2
    write(44,'(a25,i12)') 'iter_switch_speedh= ', iter_switch_speedh
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') 'DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    !write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,'(a15,f10.6)') ' debtserv_dat ', debtserv_dat
    write(44,'(a15,f10.6)') ' debtserv_sd_dat ', debtserv_sd_dat
    write(44,'(a15,f10.6)') ' hhaircut_dat  ',   hhaircut_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Calibration weights '
    write(44,'(a15,f10.6)') '    calibw_AtoY  ',   calibw_AtoY
    write(44,'(a15,f10.6)') '    calibw_sprsd ',   calibw_sprsd
    write(44,'(a15,f10.6)') '    calibw_hairc ',   calibw_hairc
    write(44,'(a15,f10.6)') '    calibw_freq  ',   calibw_freq
    write(44,'(a15,f10.6)') '    calibw_def   ',   calibw_def
    write(44,'(a15,f10.6)') '    calibw_dsd   ',   calibw_dsd
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    !write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f20.16)') 'phi1= ' , phi1
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu1

    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'pinu1     ',   pinu1_l  ,  pinu1_h
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h

    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
     param(1)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(2)=(beta-beta_l)/(beta_h-beta_l)
     param(3)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(4)=(pinu1-pinu1_l)/(pinu1_h-pinu1_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(9a9,5a9,a9,a7,a7)') 'pinu1', 'Psimin', 'phi1',  'beta ',  &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc', &
            & 'serv', 'servsd'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: Psimin, beta, phi1, pinu1 ', &
        &   (Psimin_h-Psimin_l)*param(1)+Psimin_l, &
        &   (beta_h-beta_l)*param(2)+beta_l, &
        &   (phi1_h-phi1_l)*param(3)+phi1_l, &
        &   (pinu1_h-pinu1_l)*param(4)+pinu1_l
!    write(44,*) 'param: phi, gam, Psimin, beta, Rbar, sdeta ', &
!        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
!        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
!        &   (beta_h-beta_l)*param(4)+beta_l, &
!        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
!        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ', Psimin, beta, phi1, pinu1
    !write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta

 end subroutine calib_bobyqa_case7


! **************************************************************
 subroutine calib_bobyqa_case8
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case8.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=3
    mv=9
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec
    rhoend= 0.01_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    !DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    sprstdv_dat=    0.041_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtserv_dat=    0.036_prec
    debtserv_sd_dat= 0.021_prec
    hhaircut_dat=   0.360_prec

!
! .. calibration weights ..
!
    calibw_AtoY     =3.0_prec
    calibw_sprsd    =1.25_prec
    calibw_hairc    =3.0_prec
    calibw_freq     =1.0_prec
    calibw_def      =1.0_prec
    calibw_dsd      =1.0_prec


 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	pinu1=0.589607247340112_prec !0.557303010024696_prec !0.60_prec !0.75_prec !0.50_prec
    phi1=0.52_prec !0.144353760214413_prec !0.151867516444439_prec !0.1191278_prec
!!	Psimin=0.896599199369401_prec !0.892383007777493_prec !0.90_prec !0.85_prec
	beta=0.930643558122177_prec !0.948151331675872_prec !0.93_prec

 !
 ! .. bounds ..
 !

     pinu1_l=0.51_prec !0.20_prec !0.10_prec
     pinu1_h=0.99_prec !0.50_prec !0.90_prec
     pinu1_l=0.30_prec
     pinu1_h=0.90_prec
     pinu1_l=pinu1*0.80_prec !0.30_prec
     pinu1_h=pinu1*1.20_prec !0.90_prec


     phi1_l=phi1*.70_prec
     phi1_h=phi1*1.30_prec
!!	 Psimin_l=Psimin*.90_prec
!!     Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN MAIN CODE'
    write(44,*) '--------------------------------'
    write(44,*) 'no smoothing at all - smoothing with factor_reduc=4'
    write(44,*) 'activated new barg fixes in !14aug21 !16aug21 !17aug21 '
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN INPUT FILE'
    write(44,*) '--------------------------------'
    write(44,'(a15,i12)') 'calibrcase= ', calibrcase
    write(44,'(a15,i12)') 'niter= ', niter
    write(44,'(a15,i12)') 'finiteec= ', finiteec
    write(44,'(a15,f12.9)') 'speed_adjh1= ', speed_adjh1
    write(44,'(a15,f12.9)') 'speed_adjh2= ', speed_adjh2
    write(44,'(a25,i12)') 'iter_switch_speedh= ', iter_switch_speedh
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,'(a15,f20.16)') 'Psimin= ' , Psimin
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') 'DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    !write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,'(a15,f10.6)') ' debtserv_dat ', debtserv_dat
    write(44,'(a15,f10.6)') ' debtserv_sd_dat ', debtserv_sd_dat
    write(44,'(a15,f10.6)') ' hhaircut_dat  ',   hhaircut_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Calibration weights '
    write(44,'(a15,f10.6)') '    calibw_AtoY  ',   calibw_AtoY
    write(44,'(a15,f10.6)') '    calibw_sprsd ',   calibw_sprsd
    write(44,'(a15,f10.6)') '    calibw_hairc ',   calibw_hairc
    write(44,'(a15,f10.6)') '    calibw_freq  ',   calibw_freq
    write(44,'(a15,f10.6)') '    calibw_def   ',   calibw_def
    write(44,'(a15,f10.6)') '    calibw_dsd   ',   calibw_dsd
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f20.16)') 'phi1= ' , phi1
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu1

    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'pinu1     ',   pinu1_l  ,  pinu1_h
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h

    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
     param(1)=(beta-beta_l)/(beta_h-beta_l)
     param(2)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(3)=(pinu1-pinu1_l)/(pinu1_h-pinu1_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(9a9,5a9,a9,a7,a7)') 'pinu1', 'Psimin', 'phi1',  'beta ',  &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc', &
            & 'serv', 'servsd'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: beta, phi1, pinu1 ', &
        &   (beta_h-beta_l)*param(1)+beta_l, &
        &   (phi1_h-phi1_l)*param(2)+phi1_l, &
        &   (pinu1_h-pinu1_l)*param(3)+pinu1_l


    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ',  beta, phi1, pinu1


 end subroutine calib_bobyqa_case8
! **************************************************************
 subroutine calib_bobyqa_case9
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case9.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=6 !4
    mv=10 !9
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec
    rhoend= 0.01_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    !DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    sprstdv_dat=    0.041_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtserv_dat=    0.036_prec
    debtserv_sd_dat= 0.021_prec
    logy_sd_dat=    0.100_prec
    logy_corr_dat=  0.880_prec

    !hhaircut_dat=   0.360_prec

!
! .. calibration weights ..
!
    calibw_AtoY     =3.0_prec
    calibw_sprsd    =1.25_prec  !4.0_prec
    !calibw_hairc    =3.0_prec
    calibw_freq     =1.0_prec
    calibw_def      =1.0_prec
    calibw_dsd      =1.0_prec


 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	pinu1=0.474619477941049_prec
    phi1=0.145546986392327
	Psimin= 0.893885437683567
	beta=0.933744088519083
    rhoz=0.875_prec
    sdeta=0.0516662_prec

 !
 ! .. bounds ..
 !

     pinu1_l=pinu1*0.80_prec !0.30_prec
     pinu1_h=pinu1*1.20_prec !0.90_prec


     phi1_l=phi1*0.60_prec !phi1*.70_prec
     phi1_h=phi1*1.40_prec !phi1*1.30_prec
	 Psimin_l=Psimin*.90_prec
     Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec

    sdeta_l=sdeta*0.80_prec
    sdeta_h=sdeta*1.20_prec
    rhoz_l=rhoz*0.90_prec
    rhoz_h=rhoz*1.10_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN MAIN CODE'
    write(44,*) '--------------------------------'
    write(44,*) 'no smoothing at all - smoothing with factor_reduc=4'
    write(44,*) 'activated new barg fixes in !14aug21 !16aug21 !17aug21 '
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN INPUT FILE'
    write(44,*) '--------------------------------'
    write(44,'(a15,i12)') 'calibrcase= ', calibrcase
    write(44,'(a15,i12)') 'niter= ', niter
    write(44,'(a15,i12)') 'finiteec= ', finiteec
    write(44,'(a15,f12.9)') 'speed_adjh1= ', speed_adjh1
    write(44,'(a15,f12.9)') 'speed_adjh2= ', speed_adjh2
    write(44,'(a25,i12)') 'iter_switch_speedh= ', iter_switch_speedh
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') 'DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    !write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,'(a15,f10.6)') ' debtserv_dat ', debtserv_dat
    write(44,'(a15,f10.6)') ' debtserv_sd_dat ', debtserv_sd_dat
    write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,'(a15,f10.6)') ' hhaircut_dat  ',   hhaircut_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Calibration weights '
    write(44,'(a15,f10.6)') '    calibw_AtoY  ',   calibw_AtoY
    write(44,'(a15,f10.6)') '    calibw_sprsd ',   calibw_sprsd
    !write(44,'(a15,f10.6)') '    calibw_hairc ',   calibw_hairc
    write(44,'(a15,f10.6)') '    calibw_freq  ',   calibw_freq
    write(44,'(a15,f10.6)') '    calibw_def   ',   calibw_def
    write(44,'(a15,f10.6)') '    calibw_dsd   ',   calibw_dsd
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    !write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f20.16)') 'phi1= ' , phi1
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu1
    write(44,'(a15,f20.16)') 'rhoz= ' , rhoz
    write(44,'(a15,f20.16)') 'sdeta= ' , sdeta

    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'pinu1     ',   pinu1_l  ,  pinu1_h
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,'(a15,2f10.6)') 'rhoz     ',   rhoz_l  ,  rhoz_h
    write(44,'(a15,2f10.6)') 'sdeta     ',   sdeta_l  ,  sdeta_h
    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
     param(1)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(2)=(beta-beta_l)/(beta_h-beta_l)
     param(3)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(4)=(pinu1-pinu1_l)/(pinu1_h-pinu1_l)
     param(5)=(sdeta-sdeta_l)/(sdeta_h-sdeta_l)
     param(6)=(rhoz-rhoz_l)/(rhoz_h-rhoz_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(11a9,5a9,a9,a7,a7,a7,a7)') 'rhoz', 'sdeta', 'pinu1', 'Psimin', 'phi1',  'beta ',  &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc', &
            & 'serv', 'servsd', 'corry', 'sdy'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: Psimin, beta, phi1, pinu1, sdeta, rho ', &
        &   (Psimin_h-Psimin_l)*param(1)+Psimin_l, &
        &   (beta_h-beta_l)*param(2)+beta_l, &
        &   (phi1_h-phi1_l)*param(3)+phi1_l, &
        &   (pinu1_h-pinu1_l)*param(4)+pinu1_l, &
        &   (sdeta_h-sdeta_l)*param(5)+sdeta_l, &
        &   (rhoz_h-rhoz_l)*param(6)+rhoz_l
!    write(44,*) 'param: phi, gam, Psimin, beta, Rbar, sdeta ', &
!        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
!        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
!        &   (beta_h-beta_l)*param(4)+beta_l, &
!        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
!        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ', Psimin, beta, phi1, pinu1, sdeta, rhoz
    !write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta

 end subroutine calib_bobyqa_case9
! ***********************************************************************
! **************************************************************
 subroutine calib_bobyqa_case10
  use bobyqa_module
  implicit none

 !
 ! ..  calib related ..
 !
   real(prec) :: rhobeg, rhoend
   integer :: iprint, maxfun, npt, nparam !,mv
   real(prec), dimension(:), allocatable :: param(:)
   real(prec), dimension(:), allocatable :: paraml(:), paramu(:)
   real(prec) :: val_bobyqa
   real(prec) :: kappa, rr, durat

   open(44, file='calib_bobyqa_case10.dat')

 !
 ! .. Set number parameters and targets ..
 !
    nparam=5 !4
    mv=10 !9
    npt=2*nparam+1
    maxfun = 400*(nparam+1)
    allocate(paraml(nparam),paramu(nparam))
    allocate(param(nparam))

 !
 ! .. region search parameters ..
 !
    rhobeg= 0.45_prec
    rhoend= 0.01_prec
    iprint=0

 !
 ! .. assigned param ..
 !
!!*    kappa=0.75_prec
    !rr=0.010_prec       !0.0045_prec
    !q0=one/(rr+one)


 !
 ! .. internal target values ..
 !
    !DebttoY_dat=    0.320_prec
    AtoY_dat=       0.050_prec
    sprstdv_dat=    0.041_prec
    debtstdv_dat=   0.180_prec
    dstdv_dat=      0.160_prec
    freqdef_dat=    0.340_prec
    arrears_dat=    0.340_prec
    debtserv_dat=    0.036_prec
    debtserv_sd_dat= 0.021_prec
    logy_sd_dat=    0.100_prec
    logy_corr_dat=  0.880_prec

    !hhaircut_dat=   0.360_prec

!
! .. calibration weights ..
!
    calibw_AtoY     =3.0_prec
    calibw_sprsd    =1.25_prec  !4.0_prec
    !calibw_hairc    =3.0_prec
    calibw_freq     =1.0_prec
    calibw_def      =1.0_prec
    calibw_dsd      =1.0_prec

 !
 ! .. direct params ..
 !
    !delta=one/q0-(one/q0)*(AtoY_dat/DebttoY_dat)/modelfreq

 !
 ! .. other target values ..
 !
    !logy_corr_dat=0.880_prec !0.968546928_prec (qrt)
    !smalldef_dat=    0.04_prec
    !durat=((one/q0)/((one/q0)-delta))/modelfreq

 !
 ! .. fixed param ..
 !
    !jzstar=4 !5  !4
    !rhoz=0.952_prec     !0.9672_prec     !0.968546928_prec       !0.929_prec
    !sdeta=0.0249_prec   !0.0188_prec   !0.018815693_prec      !0.0247_prec

    !call tauchen(zero, sdeta, rhoz, 3.0_prec, nz, zj, piz)
    !zj(1:nz)=exp(zj(1:nz))/two

 !
 ! .. initial params ..
 !

	pinu1=0.474619477941049_prec
    phi1=0.50_prec !0.40_prec !0.145546986392327
	!Psimin= 1.0_prec !0.893885437683567
	beta=0.933744088519083
    rhoz=0.875_prec
    sdeta=0.0516662_prec

 !
 ! .. bounds ..
 !

     pinu1_l=pinu1*0.80_prec !0.30_prec
     pinu1_h=pinu1*1.20_prec !0.90_prec


     phi1_l=phi1*0.60_prec !phi1*.70_prec
     phi1_h=phi1*1.40_prec !phi1*1.30_prec
!	 Psimin_l=Psimin*.90_prec
!    Psimin_h=Psimin*1.10_prec
     beta_l=0.90_prec
     beta_h=0.96_prec

    sdeta_l=sdeta*0.95_prec
    sdeta_h=sdeta*1.05_prec
    rhoz_l=rhoz*0.95_prec
    rhoz_h=rhoz*1.05_prec


    ! .. Write out calibration options ..
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN MAIN CODE'
    write(44,*) '--------------------------------'
    write(44,*) 'no smoothing at all - smoothing with factor_reduc=4'
    write(44,*) 'activated new barg fixes in !14aug21 !16aug21 !17aug21 '
    write(44,*) '--------------------------------'
    write(44,*)  'SETTINGS IN INPUT FILE'
    write(44,*) '--------------------------------'
    write(44,'(a15,i12)') 'calibrcase= ', calibrcase
    write(44,'(a15,i12)') 'niter= ', niter
    write(44,'(a15,i12)') 'finiteec= ', finiteec
    write(44,'(a15,f12.9)') 'speed_adjh1= ', speed_adjh1
    write(44,'(a15,f12.9)') 'speed_adjh2= ', speed_adjh2
    write(44,'(a25,i12)') 'iter_switch_speedh= ', iter_switch_speedh
    write(44,'(a15,f12.9)') 'bacc= ', bacc
    write(44,*) '--------------------------------'
    write(44,*)  'CALIBRATION SETTINGS '
    write(44,*) '--------------------------------'
    write(44,*) 'assigned param : '
    write(44,'(a15,f10.6)') 'q0= ', q0
    write(44,'(a15,f20.16)') 'rhoz= ',   rhoz
    write(44,'(a15,f20.16)') 'sigEV= ', sigEV
    write(44,'(a15,f20.16)') 'sigEV_B_nu1= ', sigEV_B_nu1
    write(44,'(a15,f20.16)') 'sigEV_B_nu2= ', sigEV_B_nu2
    write(44,'(a15,f20.16)')   'limit_spr= ', limit_spr
    write(44,'(a15,f20.16)')   'limit_Atop= ', limit_Atop
    write(44,'(a15,i10)')   'nz= ', nz
    write(44,'(a15,i10)')   'jzstar= ', jzstar
    write(44,'(a15,f20.16)') 'delta= ' ,delta
    write(44,'(a15,f10.6)') 'Psimin   ',   Psimin
    write(44,*) '--------------------------------'
    write(44,*) '# calibrated param and targets: '
    write(44,*) 'number of param ', nparam
    write(44,*) 'number of targets ', mv
    write(44,*) '--------------------------------'
    write(44,*) 'search radius: '
    write(44,'(a15,f10.6)') 'rhobeg= ', rhobeg
    write(44,'(a15,f10.6)') 'rhoend= ', rhoend
    write(44,*) '--------------------------------'
    write(44,*) 'Internal calibration targets '
    !write(44,'(a15,f10.6)') 'DebttoY_dat     ', DebttoY_dat
    write(44,'(a15,f10.6)') ' AtoY_dat     ', AtoY_dat
    write(44,'(a15,f10.6)') ' sprstdv_dat  ', sprstdv_dat
    write(44,'(a15,f10.6)') ' freqdef_dat  ', freqdef_dat
    write(44,'(a15,f10.6)') ' arrears_dat  ', arrears_dat
    write(44,'(a15,f10.6)') ' debtstdv_dat ', debtstdv_dat
    write(44,'(a15,f10.6)') ' dstdv_dat    ', dstdv_dat
    !write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,'(a15,f10.6)') ' debtserv_dat ', debtserv_dat
    write(44,'(a15,f10.6)') ' debtserv_sd_dat ', debtserv_sd_dat
    write(44,'(a15,f10.6)') ' logy_sd_dat ', logy_sd_dat
    write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,'(a15,f10.6)') ' hhaircut_dat  ',   hhaircut_dat
    write(44,*) '--------------------------------'
    write(44,*) 'Calibration weights '
    write(44,'(a15,f10.6)') '    calibw_AtoY  ',   calibw_AtoY
    write(44,'(a15,f10.6)') '    calibw_sprsd ',   calibw_sprsd
    !write(44,'(a15,f10.6)') '    calibw_hairc ',   calibw_hairc
    write(44,'(a15,f10.6)') '    calibw_freq  ',   calibw_freq
    write(44,'(a15,f10.6)') '    calibw_def   ',   calibw_def
    write(44,'(a15,f10.6)') '    calibw_dsd   ',   calibw_dsd
    write(44,*) '--------------------------------'
    write(44,*) 'Other calibration targets '
!*    write(44,'(a15,f10.6)') ' corrSpr_dat  ', corrSpr_dat
!*    write(44,'(a15,f10.6)') ' Spr_dat      ', Spr_dat
!*    write(44,'(a15,f10.6)') ' sdC_dat      ', sdC_dat
    !write(44,'(a15,f10.6)') ' smalldef_dat ', smalldef_dat
    !write(44,'(a15,f10.6)') ' logy_corr_dat ', logy_corr_dat
    !write(44,*) '--------------------------------'
    !write(44,*) 'Implied var '
    !write(44,'(a15,f10.6)') ' duration     ', durat
    write(44,*) '--------------------------------'
    write(44,*) 'Initialisation parameters '
    !write(44,'(a15,f10.6)') 'gamma_psi',   gamma_psi
    write(44,'(a15,f10.6)') 'beta     ',   beta
    write(44,'(a15,f20.16)') 'phi1= ' , phi1
    write(44,'(a15,f20.16)') 'pinu1= ' , pinu1
    write(44,'(a15,f20.16)') 'rhoz= ' , rhoz
    write(44,'(a15,f20.16)') 'sdeta= ' , sdeta

    write(44,*) '--------------------------------'
    write(44,*) 'Bounds for parameters '
    write(44,'(a15,2f10.6)') 'pinu1     ',   pinu1_l  ,  pinu1_h
    write(44,'(a15,2f10.6)') 'phi1     ',   phi1_l  ,  phi1_h
!    write(44,'(a15,2f10.6)') 'Psimin   ',   Psimin_l,  Psimin_h
    write(44,'(a15,2f10.6)') 'beta     ',   beta_l  ,  beta_h
    write(44,'(a15,2f10.6)') 'rhoz     ',   rhoz_l  ,  rhoz_h
    write(44,'(a15,2f10.6)') 'sdeta     ',   sdeta_l  ,  sdeta_h
    write(44,*) '--------------------------------'

    ! .. Normalise parameters ..
!     param(1)=(Psimin-Psimin_l)/(Psimin_h-Psimin_l)
     param(1)=(beta-beta_l)/(beta_h-beta_l)
     param(2)=(phi1-phi1_l)/(phi1_h-phi1_l)
     param(3)=(pinu1-pinu1_l)/(pinu1_h-pinu1_l)
     param(4)=(sdeta-sdeta_l)/(sdeta_h-sdeta_l)
     param(5)=(rhoz-rhoz_l)/(rhoz_h-rhoz_l)

     paraml(:)=0.0_prec
     paramu(:)=1.0_prec

    ! .. Header of table ..
    write(44,*)
    write(44,'(11a9,5a9,a9,a7,a7,a7,a7)') 'rhoz', 'sdeta', 'pinu1', 'Psimin', 'phi1',  'beta ',    &
            & 'err ', &
            & 'AtoY', 'Spr', 'freqdef', 'arrears', &
            & 'defsd ', 'sprsd ', &
            & 'debtsd', &
            & 'r_yspr', 'sdC', &
            & 'hairc', &
            & 'serv', 'servsd', 'corry', 'sdy'


    ! .. bobyqa minimisation ..
    step_calib=1
    call bobyqa (nparam, npt, param, paraml, paramu, rhobeg,rhoend,iprint,maxfun)
    write(44,*) 'COMPLETED! '

     ! .. report final outcome ..
    write(44,*) 'param: beta, phi1, pinu1, sdeta, rho ', &
        &   (beta_h-beta_l)*param(1)+beta_l, &
        &   (phi1_h-phi1_l)*param(2)+phi1_l, &
        &   (pinu1_h-pinu1_l)*param(3)+pinu1_l, &
        &   (sdeta_h-sdeta_l)*param(4)+sdeta_l, &
        &   (rhoz_h-rhoz_l)*param(5)+rhoz_l
!    write(44,*) 'param: phi, gam, Psimin, beta, Rbar, sdeta ', &
!        &   (phi1_h-phi1_l)*param(1)+phi1_l, (gamma_h-gamma_l)*param(2)+gamma_l, &
!        &   (Psimin_h-Psimin_l)*param(3)+Psimin_l, & !13jan15
!        &   (beta_h-beta_l)*param(4)+beta_l, &
!        &   (Rbar_h-Rbar_l)*param(5)+Rbar_l, &
!        &   (sdeta_h-sdeta_l)*param(6)+sdeta_l

    ! .. recompute calibrated outcomes ..
    call calfun(nparam, param, val_bobyqa)
    write(44,*) 'param from dfovec ', beta, phi1, pinu1, sdeta, rhoz
    !write(44,*) 'param from dfovec ', phi1,  gamma_psi, Psimin, beta,  Rbar(1), sdeta

 end subroutine calib_bobyqa_case10
! ***********************************************************************

end MODULE mainmodule





! *********************************************************

PROGRAM main
  !******* activate main module *******
  use mainmodule
  implicit none

    call readinfo
    call allocstuff

!
!  **************** SOLVE EQUIL (NO CALIBRATION) *****************
!
    call initstuff
    call stat_distr
    call prices_iter

    call write_inout
    call write_functions

    call simul_paths

    if((doIRF.eq.2).or.(doIRF.eq.3) &
        & .or.(doIRF.eq.4).or.(doIRF.eq.5).or.(doIRF.eq.6)) &
        &   call stochsimul_IRF(ntimeIRF,npathsIRF)
!
!  **************** END SOLVE EQUIL (NO CALIBRATION) *****************
!

!
! **********************  CALIBRATION - BOBYQA new ********************
!
!15jul21
!++    if(calibrcase.eq.1) then
!++        call calib_bobyqa_case1
!++    else if(calibrcase.eq.2) then
!++        call calib_bobyqa_case2
!++    else if(calibrcase.eq.3) then
!++        call calib_bobyqa_case3
!++    else if(calibrcase.eq.4) then
!++        call calib_bobyqa_case4
!++    else if(calibrcase.eq.5) then
!++        call calib_bobyqa_case5
!++    else if(calibrcase.eq.6) then
!++        call calib_bobyqa_case6
!++    else if(calibrcase.eq.7) then
!++        call calib_bobyqa_case7
!++    else if(calibrcase.eq.8) then
!++        call calib_bobyqa_case8
!++    else if(calibrcase.eq.9) then
!++        call calib_bobyqa_case9
!++    else if(calibrcase.eq.10) then
!++        call calib_bobyqa_case10
!++    end if
!
! **********************  END CALIBRATION - BOBYQA new ********************
!


    write(defout,*) ' Hello world! '

end PROGRAM main
